@@ -21,7 +21,7 @@ import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence
2121import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)
2222import GHCJS.DOM.Node
2323import GHCJS.DOM.UIEvent
24−import GHCJS.DOM.EventM (event, EventM)
24+import GHCJS.DOM.EventM (event, EventM, stopPropagation)
2525import GHCJS.DOM.Document
2626import GHCJS.DOM.Element
2727import GHCJS.DOM.HTMLElement
@@ -34,11 +34,25 @@ import Data.Maybe
3434import Data.GADT.Compare.TH
3535import Data.Bitraversable
3636import GHCJS.DOM.MouseEvent
37+import Data.IORef
38+import Data.Default
3739
3840type AttributeMap = Map String String
3941
42+data ElConfig attrs
43+ = ElConfig { _elConfig_namespace :: Maybe String
44+ , _elConfig_attributes :: attrs
45+ }
46+
47+makeLenses ''ElConfig
48+
49+instance (attrs ~ Map String String) => Default (ElConfig attrs) where
50+ def = ElConfig { _elConfig_namespace = Nothing
51+ , _elConfig_attributes = Map.empty
52+ }
53+
4054data El t
41− = El { _el_element :: HTMLElement
55+ = El { _el_element :: Element
4256 , _el_events :: EventSelector t (WrapArg EventResult EventName)
4357 }
4458
@@ -58,22 +72,30 @@ instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
5872 forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
5973 imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
6074
61−buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement
62−buildEmptyElement elementTag attrs = do
75+buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m Element
76+buildEmptyElementNS mns elementTag attrs = do
6377 doc <- askDocument
6478 p <- askParent
65− Just e <- liftIO $ documentCreateElement doc elementTag
79+ Just e <- liftIO $ case mns of
80+ Nothing -> documentCreateElement doc elementTag
81+ Just ns -> documentCreateElementNS doc ns elementTag
6682 addAttributes attrs e
6783 _ <- liftIO $ nodeAppendChild p $ Just e
68− return $ castToHTMLElement e
84+ return $ castToElement e
85+
86+buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m Element
87+buildEmptyElement = buildEmptyElementNS Nothing
6988
7089-- We need to decide what type of attrs we've got statically, because it will often be a recursively defined value, in which case inspecting it will lead to a cycle
71−buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)
72−buildElement elementTag attrs child = do
73− e <- buildEmptyElement elementTag attrs
90+buildElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m a -> m (Element, a)
91+buildElementNS mns elementTag attrs child = do
92+ e <- buildEmptyElementNS mns elementTag attrs
7493 result <- subWidget (toNode e) child
7594 return (e, result)
7695
96+buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (Element, a)
97+buildElement = buildElementNS Nothing
98+
7799namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
78100namedNodeMapGetNames self = do
79101 l <- namedNodeMapGetLength self
@@ -106,41 +128,33 @@ display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()
106128display a = dynText =<< mapDyn show a
107129
108130--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
131+-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
132+-- The returned Event of widget results occurs when the Dynamic does.
133+-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened.
109134dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
110135dyn child = do
111− startPlaceholder <- text' ""
112− endPlaceholder <- text' ""
113− (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
114− let e = fmap snd newChildBuilt --TODO: Get rid of this hack
115− childVoidAction <- hold never e
116− performEvent_ $ fmap (const $ return ()) e --TODO: Get rid of this hack
117− addVoidAction $ switch childVoidAction
118− doc <- askDocument
119− runWidget <- getRunWidget
120− let build c = do
121− Just df <- liftIO $ documentCreateDocumentFragment doc
122− (result, postBuild, voidActions) <- runWidget df c
123− scheduleFollowup newChildBuiltTriggerRef (result, voidActions)
124− postBuild
125− mp <- liftIO $ nodeGetParentNode endPlaceholder
126− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
127− return ()
128− schedulePostBuild $ do
129− c <- sample $ current child
130− build c
131− addVoidAction $ ffor (updated child) $ \newChild -> do
132− liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
133− build newChild
134− return $ fmap fst newChildBuilt
136+ postBuild <- getPostBuild
137+ let newChild = leftmost [updated child, tag (current child) postBuild]
138+ liftM snd $ widgetHoldInternal (return ()) newChild
135139
140+-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
141+-- The returned Dynamic of widget results occurs when the Event does.
142+-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
136143widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
137144widgetHold child0 newChild = do
145+ (result0, newResult) <- widgetHoldInternal child0 newChild
146+ holdDyn result0 newResult
147+
148+widgetHoldInternal :: MonadWidget t m => m a -> Event t (m b) -> m (a, Event t b)
149+widgetHoldInternal child0 newChild = do
138150 startPlaceholder <- text' ""
139− result0 <- child0 -- I'm pretty sure this is wrong; the void actions should get removed when the child is swapped out
151+ (result0, childVoidAction0) <- do
152+ p <- askParent
153+ subWidgetWithVoidActions p child0
140154 endPlaceholder <- text' ""
141155 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
142156 performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack
143− childVoidAction <- hold never $ fmap snd newChildBuilt
157+ childVoidAction <- hold childVoidAction0 $ fmap snd newChildBuilt
144158 addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?
145159 doc <- askDocument
146160 runWidget <- getRunWidget
@@ -149,91 +163,77 @@ widgetHold child0 newChild = do
149163 (result, postBuild, voidActions) <- runWidget df c
150164 scheduleFollowup newChildBuiltTriggerRef (result, voidActions)
151165 postBuild
152− mp <- liftIO $ nodeGetParentNode endPlaceholder
153− case mp of
154− Nothing -> return () --TODO: Is this right?
155− Just p -> do
156− _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
157− return ()
166+ mp' <- liftIO $ nodeGetParentNode endPlaceholder
167+ forM_ mp' $ \p' -> liftIO $ nodeInsertBefore p' (Just df) (Just endPlaceholder)
158168 return ()
159169 addVoidAction $ ffor newChild $ \c -> do
160170 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
161171 build c
162− holdDyn result0 $ fmap fst newChildBuilt
172+ return (result0, fmap fst newChildBuilt)
173+
174+diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
175+diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
176+ This _ -> Just Nothing
177+ These _ new -> Just $ Just new
178+ That new -> Just $ Just new
179+
180+applyMap :: Ord k => Map k v -> Map k (Maybe v) -> Map k v
181+applyMap olds diffs = flip Map.mapMaybe (align olds diffs) $ \case
182+ This old -> Just old
183+ These _ new -> new
184+ That new -> new
163185
164186--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
165−listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
187+listWithKey :: forall t k v m a. (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
166188listWithKey vals mkChild = do
167− doc <- askDocument
168− endPlaceholder <- text' ""
169− (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
170− performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
171− children <- hold Map.empty newChildren
172− addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
173− runWidget <- getRunWidget
174− let buildChild df k v = runWidget df $ do
175− childStart <- text' ""
176− result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
177− childEnd <- text' ""
178− return (result, (childStart, childEnd))
179− schedulePostBuild $ do
180− Just df <- liftIO $ documentCreateDocumentFragment doc
181− curVals <- sample $ current vals
182− initialState <- iforM curVals $ \k v -> do
183− (result, postBuild, voidAction) <- buildChild df k v
184− return ((result, voidAction), postBuild)
185− scheduleFollowup newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
186− sequence_ $ fmap snd initialState
187− mp <- liftIO $ nodeGetParentNode endPlaceholder
188− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
189− return ()
190− addVoidAction $ flip fmap (updated vals) $ \newVals -> do
191− curState <- sample children
192− --TODO: Should we remove the parent from the DOM first to avoid reflows?
193− (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
194− This ((_, (start, end)), _) -> do
195− liftIO $ deleteBetweenInclusive start end
196− return Nothing
197− That v -> do
198− Just df <- liftIO $ documentCreateDocumentFragment doc
199− (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
200− let s = (childResult, childVoidAction)
201− modify (>>childPostBuild)
202− let placeholder = case Map.lookupGT k curState of
203− Nothing -> endPlaceholder
204− Just (_, ((_, (start, _)), _)) -> start
205− mp <- liftIO $ nodeGetParentNode placeholder
206− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
207− return $ Just s
208− These state _ -> do
209− return $ Just state
210− scheduleFollowup newChildrenTriggerRef newState
211− postBuild
212− holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren
213−
214−listWithKey' :: forall t m k v a. (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
215−listWithKey' initialVals valsChanged mkChild = do
189+ postBuild <- getPostBuild
190+ rec sentVals :: Dynamic t (Map k v) <- foldDyn (flip applyMap) Map.empty changeVals
191+ let changeVals :: Event t (Map k (Maybe v))
192+ changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost
193+ [ updated vals
194+ , tag (current vals) postBuild
195+ ]
196+ listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do
197+ mkChild k =<< holdDyn v0 dv
198+
199+{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
200+listWithKey' :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
201+listWithKey' = listWithKeyShallowDiff
202+
203+-- | Display the given map of items (in key order) using the builder function provided, and update it with the given event. 'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do.
204+listWithKeyShallowDiff :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
205+listWithKeyShallowDiff initialVals valsChanged mkChild = do
206+ let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
207+ sentVals <- foldDyn (flip applyMap) Map.empty $ fmap (fmap (fmap (\_ -> ()))) valsChanged
208+ let relevantDiff diff _ = case diff of
209+ Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored
210+ Just _ -> Nothing -- We don't want to let spurious re-creations of items through
211+ listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantDiff)) (current sentVals) valsChanged) $ \k v ->
212+ mkChild k v $ select childValChangedSelector $ Const2 k
213+
214+-- | Display the given map of items using the builder function provided, and update it with the given event. 'Nothing' entries will delete the corresponding children, and 'Just' entries will create or replace them. Since child events do not take any signal arguments, they are always rebuilt. To update a child without rebuilding, either embed signals in the map's values, or refer to them directly in the builder function.
215+listHoldWithKey :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
216+listHoldWithKey initialVals valsChanged mkChild = do
216217 doc <- askDocument
217218 endPlaceholder <- text' ""
218219 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
219220-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
220221 runWidget <- getRunWidget
221− let childValChangedSelector :: EventSelector t (Const2 k v)
222− childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
223− buildChild df k v = runWidget df $ wrapChild k v
222+ let buildChild df k v = runWidget df $ wrapChild k v
224223 wrapChild k v = do
225224 childStart <- text' ""
226− result <- mkChild k v $ select childValChangedSelector $ Const2 k
225+ result <- mkChild k v
227226 childEnd <- text' ""
228227 return (result, (childStart, childEnd))
229228 Just dfOrig <- liftIO $ documentCreateDocumentFragment doc
230229 initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode dfOrig) $ wrapChild k v --Note: we have to use subWidgetWithVoidActions rather than runWidget here, because running post-build actions during build can cause not-yet-constructed values to be read
230+ stateRef <- liftIO $ newIORef initialState
231231 children <- holdDyn initialState newChildren
232232 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
233233 mpOrig <- liftIO $ nodeGetParentNode endPlaceholder
234234 forM_ mpOrig $ \pOrig -> liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)
235235 addVoidAction $ flip fmap valsChanged $ \newVals -> do
236− curState <- sample $ current children
236+ curState <- liftIO $ readIORef stateRef
237237 --TODO: Should we remove the parent from the DOM first to avoid reflows?
238238 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
239239 These ((_, (start, end)), _) Nothing -> do -- Deleting child
@@ -262,66 +262,26 @@ listWithKey' initialVals valsChanged mkChild = do
262262 return $ Just s
263263 This state -> do -- No change
264264 return $ Just state
265− scheduleFollowup newChildrenTriggerRef newState
265+ liftIO $ writeIORef stateRef newState
266+ runFrameWithTriggerRef newChildrenTriggerRef newState
266267 postBuild
267268 mapDyn (fmap (fst . fst)) children
268269
269270--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
271+-- | Create a dynamically-changing set of Event-valued widgets.
272+-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.
270273listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
271274listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
272275
273276listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
274−listViewWithKey' vals mkChild = do
275− doc <- askDocument
276− endPlaceholder <- text' ""
277− (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
278− performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
279− children <- hold Map.empty newChildren
280− addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
281− runWidget <- getRunWidget
282− let buildChild df k v = runWidget df $ do
283− childStart <- text' ""
284− result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
285− childEnd <- text' ""
286− return (result, (childStart, childEnd))
287− schedulePostBuild $ do
288− Just df <- liftIO $ documentCreateDocumentFragment doc
289− curVals <- sample $ current vals
290− initialState <- iforM curVals $ \k v -> do
291− (result, postBuild, voidAction) <- buildChild df k v
292− return ((result, voidAction), postBuild)
293− scheduleFollowup newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
294− sequence_ $ fmap snd initialState
295− mp <- liftIO $ nodeGetParentNode endPlaceholder
296− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
297− return ()
298− addVoidAction $ flip fmap (updated vals) $ \newVals -> do
299− curState <- sample children
300− --TODO: Should we remove the parent from the DOM first to avoid reflows?
301− (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
302− This ((_, (start, end)), _) -> do
303− liftIO $ deleteBetweenInclusive start end
304− return Nothing
305− That v -> do
306− Just df <- liftIO $ documentCreateDocumentFragment doc
307− (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
308− let s = (childResult, childVoidAction)
309− modify (>>childPostBuild)
310− let placeholder = case Map.lookupGT k curState of
311− Nothing -> endPlaceholder
312− Just (_, ((_, (start, _)), _)) -> start
313− mp <- liftIO $ nodeGetParentNode placeholder
314− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
315− return $ Just s
316− These state _ -> do
317− return $ Just state
318− scheduleFollowup newChildrenTriggerRef newState
319− postBuild
320− return $ fmap (fmap (fst . fst)) children
321−
322−--TODO: Deduplicate the various list*WithKey* implementations
323−
324−selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k) => Dynamic t k -> Dynamic t (Map k v) -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -> m (Event t k)
277+listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild
278+
279+-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
280+selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k)
281+ => Dynamic t k -- ^ Current selection key
282+ -> Dynamic t (Map k v) -- ^ Dynamic key/value map
283+ -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected
284+ -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
325285selectViewListWithKey_ selection vals mkChild = do
326286 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
327287 selectChild <- listWithKey vals $ \k v -> do
@@ -581,6 +541,8 @@ type family EventResultType (en :: EventTag) :: * where
581541 EventResultType 'ClickTag = ()
582542 EventResultType 'DblclickTag = ()
583543 EventResultType 'KeypressTag = Int
544+ EventResultType 'KeydownTag = Int
545+ EventResultType 'KeyupTag = Int
584546 EventResultType 'ScrollTag = Int
585547 EventResultType 'MousemoveTag = (Int, Int)
586548 EventResultType 'MousedownTag = (Int, Int)
@@ -590,6 +552,36 @@ type family EventResultType (en :: EventTag) :: * where
590552 EventResultType 'FocusTag = ()
591553 EventResultType 'BlurTag = ()
592554 EventResultType 'ChangeTag = ()
555+ EventResultType 'DragTag = ()
556+ EventResultType 'DragendTag = ()
557+ EventResultType 'DragenterTag = ()
558+ EventResultType 'DragleaveTag = ()
559+ EventResultType 'DragoverTag = ()
560+ EventResultType 'DragstartTag = ()
561+ EventResultType 'DropTag = ()
562+ EventResultType 'AbortTag = ()
563+ EventResultType 'ContextmenuTag = ()
564+ EventResultType 'ErrorTag = ()
565+ EventResultType 'InputTag = ()
566+ EventResultType 'InvalidTag = ()
567+ EventResultType 'LoadTag = ()
568+ EventResultType 'MouseoutTag = ()
569+ EventResultType 'MouseoverTag = ()
570+ EventResultType 'SelectTag = ()
571+ EventResultType 'SubmitTag = ()
572+ EventResultType 'BeforecutTag = ()
573+ EventResultType 'CutTag = ()
574+ EventResultType 'BeforecopyTag = ()
575+ EventResultType 'CopyTag = ()
576+ EventResultType 'BeforepasteTag = ()
577+ EventResultType 'PasteTag = ()
578+ EventResultType 'ResetTag = ()
579+ EventResultType 'SearchTag = ()
580+ EventResultType 'SelectstartTag = ()
581+ EventResultType 'TouchstartTag = ()
582+ EventResultType 'TouchmoveTag = ()
583+ EventResultType 'TouchendTag = ()
584+ EventResultType 'TouchcancelTag = ()
593585
594586wrapDomEventsMaybe :: (Functor (Event t), IsElement e, MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (forall en. EventName en -> EventM (EventType en) e (Maybe (f en))) -> m (EventSelector t (WrapArg f EventName))
595587wrapDomEventsMaybe element handlers = do
@@ -616,13 +608,15 @@ getKeyEvent = do
616608getMouseEventCoords :: EventM MouseEvent e (Int, Int)
617609getMouseEventCoords = do
618610 e <- event
619− liftIO $ bisequence (mouseEventGetX e, mouseEventGetY e)
611+ liftIO $ bisequence (mouseEventGetClientX e, mouseEventGetClientY e)
620612
621613defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))
622614defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
623615 Click -> return ()
624616 Dblclick -> return ()
625617 Keypress -> getKeyEvent
618+ Keydown -> getKeyEvent
619+ Keyup -> getKeyEvent
626620 Scroll -> liftIO $ elementGetScrollTop e
627621 Mousemove -> getMouseEventCoords
628622 Mouseup -> getMouseEventCoords
@@ -632,92 +626,153 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
632626 Focus -> return ()
633627 Blur -> return ()
634628 Change -> return ()
635−
636−wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
637−wrapElement e = do
638− es <- wrapDomEventsMaybe e $ defaultDomEventHandler e
629+ Drag -> return ()
630+ Dragend -> return ()
631+ Dragenter -> return ()
632+ Dragleave -> return ()
633+ Dragover -> return ()
634+ Dragstart -> return ()
635+ Drop -> return ()
636+ Abort -> return ()
637+ Contextmenu -> return ()
638+ Error -> return ()
639+ Input -> return ()
640+ Invalid -> return ()
641+ Load -> return ()
642+ Mouseout -> return ()
643+ Mouseover -> return ()
644+ Select -> return ()
645+ Submit -> return ()
646+ Beforecut -> return ()
647+ Cut -> return ()
648+ Beforecopy -> return ()
649+ Copy -> return ()
650+ Beforepaste -> return ()
651+ Paste -> return ()
652+ Reset -> return ()
653+ Search -> return ()
654+ Selectstart -> return ()
655+ Touchstart -> return ()
656+ Touchmove -> return ()
657+ Touchend -> return ()
658+ Touchcancel -> return ()
659+
660+wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => (forall en. Element -> EventName en -> EventM (EventType en) Element (Maybe (EventResult en))) -> Element -> m (El t)
661+wrapElement eh e = do
662+ es <- wrapDomEventsMaybe e $ eh e
639663 return $ El e es
640664
641−elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
642−elDynAttr' elementTag attrs child = do
643− (e, result) <- buildElement elementTag attrs child
644− e' <- wrapElement e
665+{-# INLINABLE elStopPropagationNS #-}
666+elStopPropagationNS :: (MonadWidget t m, IsEvent (EventType en)) => Maybe String -> String -> EventName en -> m a -> m a
667+elStopPropagationNS mns elementTag evt child = do
668+ (e, result) <- buildElementNS mns elementTag (Map.empty :: Map String String) child
669+ _ <- liftIO $ onEventName evt e stopPropagation
670+ return result
671+
672+{-# INLINABLE elWith #-}
673+elWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m a
674+elWith elementTag cfg child = do
675+ (_, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
676+ return result
677+
678+{-# INLINABLE elWith' #-}
679+elWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m (El t, a)
680+elWith' elementTag cfg child = do
681+ (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
682+ e' <- wrapElement defaultDomEventHandler e
645683 return (e', result)
646684
685+{-# INLINABLE emptyElWith #-}
686+emptyElWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m ()
687+emptyElWith elementTag cfg = do
688+ _ <- buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
689+ return ()
690+
691+{-# INLINABLE emptyElWith' #-}
692+emptyElWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m (El t)
693+emptyElWith' elementTag cfg = do
694+ wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
695+
696+{-# INLINABLE elDynAttrNS' #-}
697+elDynAttrNS' :: forall t m a. MonadWidget t m => Maybe String -> String -> Dynamic t (Map String String) -> m a -> m (El t, a)
698+elDynAttrNS' mns elementTag attrs = elWith' elementTag $
699+ def & namespace .~ mns
700+ & elConfig_attributes .~ attrs
701+
702+{-# INLINABLE elDynAttr' #-}
703+elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
704+elDynAttr' elementTag attrs = elWith' elementTag $ def & elConfig_attributes .~ attrs
705+
647706{-# INLINABLE elAttr #-}
648707elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
649−elAttr elementTag attrs child = do
650− (_, result) <- buildElement elementTag attrs child
651− return result
708+elAttr elementTag attrs = elWith elementTag $ def & attributes .~ attrs
652709
653710{-# INLINABLE el' #-}
654711el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
655−el' elementTag child = elAttr' elementTag (Map.empty :: AttributeMap) child
712+el' elementTag = elWith' elementTag def
656713
657714{-# INLINABLE elAttr' #-}
658715elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
659−elAttr' elementTag attrs child = do
660− (e, result) <- buildElement elementTag attrs child
661− e' <- wrapElement e
662− return (e', result)
716+elAttr' elementTag attrs = elWith' elementTag $ def & attributes .~ attrs
663717
664718{-# INLINABLE elDynAttr #-}
665719elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
666−elDynAttr elementTag attrs child = do
667− (_, result) <- buildElement elementTag attrs child
668− return result
720+elDynAttr elementTag attrs = elWith elementTag $ def & elConfig_attributes .~ attrs
669721
670722{-# INLINABLE el #-}
671723el :: forall t m a. MonadWidget t m => String -> m a -> m a
672−el elementTag child = elAttr elementTag Map.empty child
724+el elementTag = elWith elementTag def
673725
674726elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
675−elClass elementTag c child = elAttr elementTag ("class" =: c) child
727+elClass elementTag c = elWith elementTag $ def & attributes .~ "class" =: c
676728
677729--------------------------------------------------------------------------------
678730-- Copied and pasted from Reflex.Widget.Class
679731--------------------------------------------------------------------------------
680732
733+-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
734+-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
681735list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
682736list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
683737
738+-- | Create a dynamically-changing set of widgets from a Dynamic list.
684739simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
685740simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs
686741
687742elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
688743elDynHtml' elementTag html = do
689744 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
690− schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
691− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
692− wrapElement e
745+ let h = castToHTMLElement e
746+ schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
747+ addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
748+ wrapElement defaultDomEventHandler e
693749
694750elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
695751elDynHtmlAttr' elementTag attrs html = do
696752 e <- buildEmptyElement elementTag attrs
697− schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
698− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
699− wrapElement e
700−
701−{-
702−
703−--TODO: Update dynamically
704−{-# INLINABLE dynHtml #-}
705−dynHtml :: MonadWidget t m => Dynamic t String -> m ()
706−dynHtml ds = do
707− let mkSelf h = do
708− doc <- askDocument
709− Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "div"
710− liftIO $ htmlElementSetInnerHTML e h
711− return e
712− eCreated <- performEvent . fmap mkSelf . tagDyn ds =<< getEInit
713− putEChildren $ fmap ((:[]) . toNode) eCreated
714−
715−-}
753+ let h = castToHTMLElement e
754+ schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
755+ addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
756+ wrapElement defaultDomEventHandler e
716757
717758data Link t
718759 = Link { _link_clicked :: Event t ()
719760 }
720761
762+class HasAttributes a where
763+ type Attrs a :: *
764+ attributes :: Lens' a (Attrs a)
765+
766+instance HasAttributes (ElConfig attrs) where
767+ type Attrs (ElConfig attrs) = attrs
768+ attributes = elConfig_attributes
769+
770+class HasNamespace a where
771+ namespace :: Lens' a (Maybe String)
772+
773+instance HasNamespace (ElConfig attrs) where
774+ namespace = elConfig_namespace
775+
721776class HasDomEvent t a where
722777 domEvent :: EventName en -> a -> Event t (EventResultType en)
723778
@@ -761,7 +816,13 @@ dtdd h w = do
761816blank :: forall t m. MonadWidget t m => m ()
762817blank = return ()
763818
764−tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k) => String -> [(String, k -> Dynamic t r -> m v)] -> Dynamic t (Map k r) -> (k -> m (Dynamic t (Map String String))) -> m (Dynamic t (Map k (El t, [v])))
819+-- | A widget to display a table with static columns and dynamic rows.
820+tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k)
821+ => String -- ^ Class applied to <table> element
822+ -> [(String, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
823+ -> Dynamic t (Map k r) -- ^ Map from row key to row value
824+ -> (k -> m (Dynamic t (Map String String))) -- ^ Function to compute <tr> element attributes from row key
825+ -> m (Dynamic t (Map k (El t, [v]))) -- ^ Map from row key to (El, list of widget return values)
765826tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
766827 elAttr "table" (Map.singleton "class" klass) $ do
767828 el "thead" $ el "tr" $ do
@@ -771,7 +832,15 @@ tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zo
771832 dAttrs <- rowAttrs k
772833 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
773834
774−tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
835+--TODO preselect a tab on open
836+-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
837+-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
838+-- the corresponding child and hides all others.
839+tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k)
840+ => String -- ^ Class applied to <ul> element
841+ -> String -- ^ Class applied to currently active <li> element
842+ -> Map k (String, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)
843+ -> m ()
775844tabDisplay ulClass activeClass tabItems = do
776845 let t0 = listToMaybe $ Map.keys tabItems
777846 rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do
@@ -793,11 +862,11 @@ tabDisplay ulClass activeClass tabItems = do
793862 return $ fmap (const k) (_link_clicked a)
794863
795864-- | Place an element into the DOM and wrap it with Reflex event handlers. Note: undefined behavior may result if the element is placed multiple times, removed from the DOM after being placed, or in other situations. Don't use this unless you understand the internals of MonadWidget.
796−unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)
865+unsafePlaceElement :: MonadWidget t m => Element -> m (El t)
797866unsafePlaceElement e = do
798867 p <- askParent
799868 _ <- liftIO $ nodeAppendChild p $ Just e
800− wrapElement e
869+ wrapElement defaultDomEventHandler e
801870
802871deriveGEq ''EventName
803872deriveGCompare ''EventName