git.iko.soy/reflex-dom
on f0a02fb help sign in
reflex-dom/src/Reflex/Dom/Widget/Basic.hs
907 lines 39 kB history raw
1{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes, TemplateHaskell #-}
3module Reflex.Dom.Widget.Basic where
5import Reflex.Dom.Class
6import Reflex.Dom.Internal.Foreign ()
8import Prelude hiding (mapM, mapM_, sequence, sequence_)
9import Reflex
10import Reflex.Host.Class
11import Data.Functor.Misc
12import Data.Map (Map)
13import qualified Data.Map as Map
14import Data.Set (Set)
15import qualified Data.Set as Set
16import Data.Dependent.Sum (DSum (..))
17import Data.Foldable
18import Data.Traversable
19import Control.Monad.Trans
20import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
21import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)
22import GHCJS.DOM.Node
23import GHCJS.DOM.UIEvent
24import GHCJS.DOM.EventM (on, event, EventM, stopPropagation)
25import GHCJS.DOM.Document
26import GHCJS.DOM.Element as E
27import GHCJS.DOM.Types hiding (Event)
28import qualified GHCJS.DOM.Types as DOM (Event)
29import GHCJS.DOM.NamedNodeMap as NNM
30import Control.Lens hiding (element, children)
31import Data.These
32import Data.Align
33import Data.Maybe
34import Data.GADT.Compare.TH
35import Data.Bitraversable
36import GHCJS.DOM.MouseEvent
37import Data.IORef
38import Data.Default
40type AttributeMap = Map String String
42data ElConfig attrs
43 = ElConfig { _elConfig_namespace :: Maybe String
44 , _elConfig_attributes :: attrs
45 }
47makeLenses ''ElConfig
49instance (attrs ~ Map String String) => Default (ElConfig attrs) where
50 def = ElConfig { _elConfig_namespace = Nothing
51 , _elConfig_attributes = Map.empty
52 }
54data El t
55 = El { _el_element :: Element
56 , _el_events :: EventSelector t (WrapArg EventResult EventName)
57 }
59class Attributes m a where
60 addAttributes :: IsElement e => a -> e -> m ()
62instance MonadIO m => Attributes m AttributeMap where
63 addAttributes curAttrs e = imapM_ (setAttribute e) curAttrs
65instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
66 addAttributes attrs e = do
67 schedulePostBuild $ do
68 curAttrs <- sample $ current attrs
69 imapM_ (setAttribute e) curAttrs
70 addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do
71 oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< getAttributes e
72 forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ removeAttribute e
73 imapM_ (setAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
75buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m Element
76buildEmptyElementNS mns elementTag attrs = do
77 doc <- askDocument
78 p <- askParent
79 Just e <- liftIO $ case mns of
80 Nothing -> createElement doc (Just elementTag)
81 Just ns -> createElementNS doc (Just ns) (Just elementTag)
82 addAttributes attrs e
83 _ <- appendChild p $ Just e
84 return $ castToElement e
86buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m Element
87buildEmptyElement = buildEmptyElementNS Nothing
89-- 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
90buildElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m a -> m (Element, a)
91buildElementNS mns elementTag attrs child = do
92 e <- buildEmptyElementNS mns elementTag attrs
93 result <- subWidget (toNode e) child
94 return (e, result)
96buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (Element, a)
97buildElement = buildElementNS Nothing
99namedNodeMapGetNames :: NamedNodeMap -> IO (Set String)
100namedNodeMapGetNames self = do
101 l <- NNM.getLength self
102 let locations = if l == 0 then [] else [0..l-1] -- Can't use 0..l-1 if l is 0 because l is unsigned and will wrap around
103 liftM (Set.fromList . catMaybes) $ forM locations $ \i -> do
104 Just n <- NNM.item self i
105 getNodeName n
107text :: MonadWidget t m => String -> m ()
108text = void . text'
110--TODO: Wrap the result
111text' :: MonadWidget t m => String -> m Text
112text' s = do
113 doc <- askDocument
114 p <- askParent
115 Just n <- createTextNode doc s
116 _ <- appendChild p $ Just n
117 return n
119dynText :: MonadWidget t m => Dynamic t String -> m ()
120dynText s = do
121 n <- text' ""
122 schedulePostBuild $ do
123 curS <- sample $ current s
124 setNodeValue n $ Just curS
125 addVoidAction $ fmap (setNodeValue n . Just) $ updated s
127display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()
128display a = dynText =<< mapDyn show a
130--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 (via 'switchPromptly').
134dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
135dyn child = do
136 postBuild <- getPostBuild
137 let newChild = leftmost [updated child, tag (current child) postBuild]
138 liftM snd $ widgetHoldInternal (return ()) newChild
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.
143widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
144widgetHold child0 newChild = do
145 (result0, newResult) <- widgetHoldInternal child0 newChild
146 holdDyn result0 newResult
148widgetHoldInternal :: MonadWidget t m => m a -> Event t (m b) -> m (a, Event t b)
149widgetHoldInternal child0 newChild = do
150 startPlaceholder <- text' ""
151 (result0, childVoidAction0) <- do
152 p <- askParent
153 subWidgetWithVoidActions p child0
154 endPlaceholder <- text' ""
155 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
156 performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack
157 childVoidAction <- hold childVoidAction0 $ fmap snd newChildBuilt
158 addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?
159 doc <- askDocument
160 runWidget <- getRunWidget
161 addVoidAction $ ffor newChild $ \c -> do
162 Just df <- createDocumentFragment doc
163 (result, postBuild, voidActions) <- runWidget df c
164 runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)
165 postBuild
166 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
167 mp' <- getParentNode endPlaceholder
168 forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder)
169 return ()
170 return (result0, fmap fst newChildBuilt)
172diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
173diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
174 This _ -> Just Nothing
175 These _ new -> Just $ Just new
176 That new -> Just $ Just new
178applyMap :: Ord k => Map k v -> Map k (Maybe v) -> Map k v
179applyMap olds diffs = flip Map.mapMaybe (align olds diffs) $ \case
180 This old -> Just old
181 These _ new -> new
182 That new -> new
184--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
185listWithKey :: 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))
186listWithKey vals mkChild = do
187 postBuild <- getPostBuild
188 rec sentVals :: Dynamic t (Map k v) <- foldDyn (flip applyMap) Map.empty changeVals
189 let changeVals :: Event t (Map k (Maybe v))
190 changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost
191 [ updated vals
192 , tag (current vals) postBuild
193 ]
194 listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do
195 mkChild k =<< holdDyn v0 dv
197{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
198listWithKey' :: (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))
199listWithKey' = listWithKeyShallowDiff
201-- | 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.
202listWithKeyShallowDiff :: (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))
203listWithKeyShallowDiff initialVals valsChanged mkChild = do
204 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
205 sentVals <- foldDyn (flip applyMap) Map.empty $ fmap (fmap (fmap (\_ -> ()))) valsChanged
206 let relevantDiff diff _ = case diff of
207 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
208 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
209 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantDiff)) (current sentVals) valsChanged) $ \k v ->
210 mkChild k v $ Reflex.select childValChangedSelector $ Const2 k
212-- | 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.
213listHoldWithKey :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
214listHoldWithKey initialVals valsChanged mkChild = do
215 doc <- askDocument
216 endPlaceholder <- text' ""
217 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
218-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
219 runWidget <- getRunWidget
220 let buildChild df k v = runWidget df $ wrapChild k v
221 wrapChild k v = do
222 childStart <- text' ""
223 result <- mkChild k v
224 childEnd <- text' ""
225 return (result, (childStart, childEnd))
226 Just dfOrig <- createDocumentFragment doc
227 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
228 stateRef <- liftIO $ newIORef initialState
229 children <- holdDyn initialState newChildren
230 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
231 mpOrig <- getParentNode endPlaceholder
232 forM_ mpOrig $ \pOrig -> insertBefore pOrig (Just dfOrig) (Just endPlaceholder)
233 addVoidAction $ flip fmap valsChanged $ \newVals -> do
234 curState <- liftIO $ readIORef stateRef
235 --TODO: Should we remove the parent from the DOM first to avoid reflows?
236 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
237 These ((_, (start, end)), _) Nothing -> do -- Deleting child
238 liftIO $ deleteBetweenInclusive start end
239 return Nothing
240 These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child
241 liftIO $ deleteBetweenExclusive start end
242 Just df <- createDocumentFragment doc
243 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
244 let s = (childResult, childVoidAction)
245 modify (>>childPostBuild)
246 mp <- getParentNode end
247 forM_ mp $ \p -> insertBefore p (Just df) (Just end)
248 return $ Just s
249 That Nothing -> return Nothing -- Deleting non-existent child
250 That (Just v) -> do -- Creating new child
251 Just df <- createDocumentFragment doc
252 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
253 let s = (childResult, childVoidAction)
254 modify (>>childPostBuild)
255 let placeholder = case Map.lookupGT k curState of
256 Nothing -> endPlaceholder
257 Just (_, ((_, (start, _)), _)) -> start
258 mp <- getParentNode placeholder
259 forM_ mp $ \p -> insertBefore p (Just df) (Just placeholder)
260 return $ Just s
261 This state -> do -- No change
262 return $ Just state
263 liftIO $ writeIORef stateRef newState
264 runFrameWithTriggerRef newChildrenTriggerRef newState
265 postBuild
266 mapDyn (fmap (fst . fst)) children
268--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
269-- | Create a dynamically-changing set of Event-valued widgets.
270-- 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'.
271listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
272listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
274listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
275listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild
277-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
278selectViewListWithKey :: forall t m k v a. (MonadWidget t m, Ord k)
279 => Dynamic t k -- ^ Current selection key
280 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
281 -> (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
282 -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
283selectViewListWithKey selection vals mkChild = do
284 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
285 selectChild <- listWithKey vals $ \k v -> do
286 selected <- getDemuxed selectionDemux k
287 selectSelf <- mkChild k v selected
288 return $ fmap ((,) k) selectSelf
289 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
291selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k)
292 => Dynamic t k -- ^ Current selection key
293 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
294 -> (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
295 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
296selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewListWithKey selection vals mkChild
298--------------------------------------------------------------------------------
299-- Basic DOM manipulation helpers
300--------------------------------------------------------------------------------
302-- | s and e must both be children of the same node and s must precede e
303deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
304deleteBetweenExclusive s e = do
305 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
306 case mCurrentParent of
307 Nothing -> return () --TODO: Is this the right behavior?
308 Just currentParent -> do
309 let go = do
310 Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
311 when (toNode s /= toNode x) $ do
312 _ <- removeChild currentParent $ Just x
313 go
314 go
316-- | s and e must both be children of the same node and s must precede e
317deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
318deleteBetweenInclusive s e = do
319 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
320 case mCurrentParent of
321 Nothing -> return () --TODO: Is this the right behavior?
322 Just currentParent -> do
323 let go = do
324 Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
325 _ <- removeChild currentParent $ Just x
326 when (toNode s /= toNode x) go
327 go
328 _ <- removeChild currentParent $ Just e
329 return ()
331nodeClear :: IsNode self => self -> IO ()
332nodeClear n = do
333 mfc <- getFirstChild n
334 case mfc of
335 Nothing -> return ()
336 Just fc -> do
337 _ <- removeChild n $ Just fc
338 nodeClear n
340--------------------------------------------------------------------------------
341-- Adapters
342--------------------------------------------------------------------------------
344wrapDomEvent :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event a -> m (Event t a)
345wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue
347wrapDomEventMaybe :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event (Maybe a) -> m (Event t a)
348wrapDomEventMaybe element elementOnevent getValue = do
349 postGui <- askPostGui
350 runWithActions <- askRunWithActions
351 e <- newEventWithTrigger $ \et -> do
352 unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
353 mv <- {-# SCC "d" #-} getValue
354 forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]
355 return $ liftIO $ do
356 {-# SCC "e" #-} unsubscribe
357 return $! {-# SCC "f" #-} e
359data EventTag
360 = AbortTag
361 | BlurTag
362 | ChangeTag
363 | ClickTag
364 | ContextmenuTag
365 | DblclickTag
366 | DragTag
367 | DragendTag
368 | DragenterTag
369 | DragleaveTag
370 | DragoverTag
371 | DragstartTag
372 | DropTag
373 | ErrorTag
374 | FocusTag
375 | InputTag
376 | InvalidTag
377 | KeydownTag
378 | KeypressTag
379 | KeyupTag
380 | LoadTag
381 | MousedownTag
382 | MouseenterTag
383 | MouseleaveTag
384 | MousemoveTag
385 | MouseoutTag
386 | MouseoverTag
387 | MouseupTag
388 | MousewheelTag
389 | ScrollTag
390 | SelectTag
391 | SubmitTag
392 | WheelTag
393 | BeforecutTag
394 | CutTag
395 | BeforecopyTag
396 | CopyTag
397 | BeforepasteTag
398 | PasteTag
399 | ResetTag
400 | SearchTag
401 | SelectstartTag
402 | TouchstartTag
403 | TouchmoveTag
404 | TouchendTag
405 | TouchcancelTag
407data EventName :: EventTag -> * where
408 Abort :: EventName 'AbortTag
409 Blur :: EventName 'BlurTag
410 Change :: EventName 'ChangeTag
411 Click :: EventName 'ClickTag
412 Contextmenu :: EventName 'ContextmenuTag
413 Dblclick :: EventName 'DblclickTag
414 Drag :: EventName 'DragTag
415 Dragend :: EventName 'DragendTag
416 Dragenter :: EventName 'DragenterTag
417 Dragleave :: EventName 'DragleaveTag
418 Dragover :: EventName 'DragoverTag
419 Dragstart :: EventName 'DragstartTag
420 Drop :: EventName 'DropTag
421 Error :: EventName 'ErrorTag
422 Focus :: EventName 'FocusTag
423 Input :: EventName 'InputTag
424 Invalid :: EventName 'InvalidTag
425 Keydown :: EventName 'KeydownTag
426 Keypress :: EventName 'KeypressTag
427 Keyup :: EventName 'KeyupTag
428 Load :: EventName 'LoadTag
429 Mousedown :: EventName 'MousedownTag
430 Mouseenter :: EventName 'MouseenterTag
431 Mouseleave :: EventName 'MouseleaveTag
432 Mousemove :: EventName 'MousemoveTag
433 Mouseout :: EventName 'MouseoutTag
434 Mouseover :: EventName 'MouseoverTag
435 Mouseup :: EventName 'MouseupTag
436 Mousewheel :: EventName 'MousewheelTag
437 Scroll :: EventName 'ScrollTag
438 Select :: EventName 'SelectTag
439 Submit :: EventName 'SubmitTag
440 Wheel :: EventName 'WheelTag
441 Beforecut :: EventName 'BeforecutTag
442 Cut :: EventName 'CutTag
443 Beforecopy :: EventName 'BeforecopyTag
444 Copy :: EventName 'CopyTag
445 Beforepaste :: EventName 'BeforepasteTag
446 Paste :: EventName 'PasteTag
447 Reset :: EventName 'ResetTag
448 Search :: EventName 'SearchTag
449 Selectstart :: EventName 'SelectstartTag
450 Touchstart :: EventName 'TouchstartTag
451 Touchmove :: EventName 'TouchmoveTag
452 Touchend :: EventName 'TouchendTag
453 Touchcancel :: EventName 'TouchcancelTag
455type family EventType en where
456 EventType 'AbortTag = UIEvent
457 EventType 'BlurTag = FocusEvent
458 EventType 'ChangeTag = DOM.Event
459 EventType 'ClickTag = MouseEvent
460 EventType 'ContextmenuTag = MouseEvent
461 EventType 'DblclickTag = MouseEvent
462 EventType 'DragTag = MouseEvent
463 EventType 'DragendTag = MouseEvent
464 EventType 'DragenterTag = MouseEvent
465 EventType 'DragleaveTag = MouseEvent
466 EventType 'DragoverTag = MouseEvent
467 EventType 'DragstartTag = MouseEvent
468 EventType 'DropTag = MouseEvent
469 EventType 'ErrorTag = UIEvent
470 EventType 'FocusTag = FocusEvent
471 EventType 'InputTag = DOM.Event
472 EventType 'InvalidTag = DOM.Event
473 EventType 'KeydownTag = KeyboardEvent
474 EventType 'KeypressTag = KeyboardEvent
475 EventType 'KeyupTag = KeyboardEvent
476 EventType 'LoadTag = UIEvent
477 EventType 'MousedownTag = MouseEvent
478 EventType 'MouseenterTag = MouseEvent
479 EventType 'MouseleaveTag = MouseEvent
480 EventType 'MousemoveTag = MouseEvent
481 EventType 'MouseoutTag = MouseEvent
482 EventType 'MouseoverTag = MouseEvent
483 EventType 'MouseupTag = MouseEvent
484 EventType 'MousewheelTag = MouseEvent
485 EventType 'ScrollTag = UIEvent
486 EventType 'SelectTag = UIEvent
487 EventType 'SubmitTag = DOM.Event
488 EventType 'WheelTag = WheelEvent
489 EventType 'BeforecutTag = DOM.Event
490 EventType 'CutTag = DOM.Event
491 EventType 'BeforecopyTag = DOM.Event
492 EventType 'CopyTag = DOM.Event
493 EventType 'BeforepasteTag = DOM.Event
494 EventType 'PasteTag = DOM.Event
495 EventType 'ResetTag = DOM.Event
496 EventType 'SearchTag = DOM.Event
497 EventType 'SelectstartTag = DOM.Event
498 EventType 'TouchstartTag = TouchEvent
499 EventType 'TouchmoveTag = TouchEvent
500 EventType 'TouchendTag = TouchEvent
501 EventType 'TouchcancelTag = TouchEvent
503onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
504onEventName en e = case en of
505 Abort -> on e E.abort
506 Blur -> on e E.blurEvent
507 Change -> on e E.change
508 Click -> on e E.click
509 Contextmenu -> on e E.contextMenu
510 Dblclick -> on e E.dblClick
511 Drag -> on e E.drag
512 Dragend -> on e E.dragEnd
513 Dragenter -> on e E.dragEnter
514 Dragleave -> on e E.dragLeave
515 Dragover -> on e E.dragOver
516 Dragstart -> on e E.dragStart
517 Drop -> on e E.drop
518 Error -> on e E.error
519 Focus -> on e E.focusEvent
520 Input -> on e E.input
521 Invalid -> on e E.invalid
522 Keydown -> on e E.keyDown
523 Keypress -> on e E.keyPress
524 Keyup -> on e E.keyUp
525 Load -> on e E.load
526 Mousedown -> on e E.mouseDown
527 Mouseenter -> on e E.mouseEnter
528 Mouseleave -> on e E.mouseLeave
529 Mousemove -> on e E.mouseMove
530 Mouseout -> on e E.mouseOut
531 Mouseover -> on e E.mouseOver
532 Mouseup -> on e E.mouseUp
533 Mousewheel -> on e E.mouseWheel
534 Scroll -> on e E.scroll
535 Select -> on e E.select
536 Submit -> on e E.submit
537 Wheel -> on e E.wheel
538 Beforecut -> on e E.beforeCut
539 Cut -> on e E.cut
540 Beforecopy -> on e E.beforeCopy
541 Copy -> on e E.copy
542 Beforepaste -> on e E.beforePaste
543 Paste -> on e E.paste
544 Reset -> on e E.reset
545 Search -> on e E.search
546 Selectstart -> on e E.selectStart
547 Touchstart -> on e E.touchStart
548 Touchmove -> on e E.touchMove
549 Touchend -> on e E.touchEnd
550 Touchcancel -> on e E.touchCancel
552newtype EventResult en = EventResult { unEventResult :: EventResultType en }
554type family EventResultType (en :: EventTag) :: * where
555 EventResultType 'ClickTag = ()
556 EventResultType 'DblclickTag = ()
557 EventResultType 'KeypressTag = Int
558 EventResultType 'KeydownTag = Int
559 EventResultType 'KeyupTag = Int
560 EventResultType 'ScrollTag = Int
561 EventResultType 'MousemoveTag = (Int, Int)
562 EventResultType 'MousedownTag = (Int, Int)
563 EventResultType 'MouseupTag = (Int, Int)
564 EventResultType 'MouseenterTag = ()
565 EventResultType 'MouseleaveTag = ()
566 EventResultType 'FocusTag = ()
567 EventResultType 'BlurTag = ()
568 EventResultType 'ChangeTag = ()
569 EventResultType 'DragTag = ()
570 EventResultType 'DragendTag = ()
571 EventResultType 'DragenterTag = ()
572 EventResultType 'DragleaveTag = ()
573 EventResultType 'DragoverTag = ()
574 EventResultType 'DragstartTag = ()
575 EventResultType 'DropTag = ()
576 EventResultType 'AbortTag = ()
577 EventResultType 'ContextmenuTag = ()
578 EventResultType 'ErrorTag = ()
579 EventResultType 'InputTag = ()
580 EventResultType 'InvalidTag = ()
581 EventResultType 'LoadTag = ()
582 EventResultType 'MouseoutTag = ()
583 EventResultType 'MouseoverTag = ()
584 EventResultType 'SelectTag = ()
585 EventResultType 'SubmitTag = ()
586 EventResultType 'BeforecutTag = ()
587 EventResultType 'CutTag = ()
588 EventResultType 'BeforecopyTag = ()
589 EventResultType 'CopyTag = ()
590 EventResultType 'BeforepasteTag = ()
591 EventResultType 'PasteTag = ()
592 EventResultType 'ResetTag = ()
593 EventResultType 'SearchTag = ()
594 EventResultType 'SelectstartTag = ()
595 EventResultType 'TouchstartTag = ()
596 EventResultType 'TouchmoveTag = ()
597 EventResultType 'TouchendTag = ()
598 EventResultType 'TouchcancelTag = ()
599 EventResultType 'MousewheelTag = ()
600 EventResultType 'WheelTag = ()
602wrapDomEventsMaybe :: (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 e (EventType en) (Maybe (f en))) -> m (EventSelector t (WrapArg f EventName))
603wrapDomEventsMaybe element handlers = do
604 postGui <- askPostGui
605 runWithActions <- askRunWithActions
606 e <- newFanEventWithTrigger $ \(WrapArg en) et -> do
607 unsubscribe <- onEventName en element $ do
608 mv <- handlers en
609 forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]
610 return $ liftIO $ do
611 unsubscribe
612 return $! e
614getKeyEvent :: EventM e KeyboardEvent Int
615getKeyEvent = do
616 e <- event
617 which <- getWhich e
618 if which /= 0 then return which else do
619 charCode <- getCharCode e
620 if charCode /= 0 then return charCode else
621 getKeyCode e
623getMouseEventCoords :: EventM e MouseEvent (Int, Int)
624getMouseEventCoords = do
625 e <- event
626 bisequence (getX e, getY e)
628defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))
629defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
630 Click -> return ()
631 Dblclick -> return ()
632 Keypress -> getKeyEvent
633 Scroll -> getScrollTop e
634 Keydown -> getKeyEvent
635 Keyup -> getKeyEvent
636 Mousemove -> getMouseEventCoords
637 Mouseup -> getMouseEventCoords
638 Mousedown -> getMouseEventCoords
639 Mouseenter -> return ()
640 Mouseleave -> return ()
641 Focus -> return ()
642 Blur -> return ()
643 Change -> return ()
644 Drag -> return ()
645 Dragend -> return ()
646 Dragenter -> return ()
647 Dragleave -> return ()
648 Dragover -> return ()
649 Dragstart -> return ()
650 Drop -> return ()
651 Abort -> return ()
652 Contextmenu -> return ()
653 Error -> return ()
654 Input -> return ()
655 Invalid -> return ()
656 Load -> return ()
657 Mouseout -> return ()
658 Mouseover -> return ()
659 Select -> return ()
660 Submit -> return ()
661 Beforecut -> return ()
662 Cut -> return ()
663 Beforecopy -> return ()
664 Copy -> return ()
665 Beforepaste -> return ()
666 Paste -> return ()
667 Reset -> return ()
668 Search -> return ()
669 Selectstart -> return ()
670 Touchstart -> return ()
671 Touchmove -> return ()
672 Touchend -> return ()
673 Touchcancel -> return ()
674 Mousewheel -> return ()
675 Wheel -> return ()
677wrapElement :: 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 Element (EventType en) (Maybe (EventResult en))) -> Element -> m (El t)
678wrapElement eh e = do
679 es <- wrapDomEventsMaybe e $ eh e
680 return $ El e es
682{-# INLINABLE elStopPropagationNS #-}
683elStopPropagationNS :: (MonadWidget t m, IsEvent (EventType en)) => Maybe String -> String -> EventName en -> m a -> m a
684elStopPropagationNS mns elementTag evt child = do
685 (e, result) <- buildElementNS mns elementTag (Map.empty :: Map String String) child
686 _ <- liftIO $ onEventName evt e stopPropagation
687 return result
689{-# INLINABLE elWith #-}
690elWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m a
691elWith elementTag cfg child = do
692 (_, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
693 return result
695{-# INLINABLE elWith' #-}
696elWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m (El t, a)
697elWith' elementTag cfg child = do
698 (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
699 e' <- wrapElement defaultDomEventHandler e
700 return (e', result)
702{-# INLINABLE emptyElWith #-}
703emptyElWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m ()
704emptyElWith elementTag cfg = do
705 _ <- buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
706 return ()
708{-# INLINABLE emptyElWith' #-}
709emptyElWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m (El t)
710emptyElWith' elementTag cfg = do
711 wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
713{-# INLINABLE elDynAttrNS' #-}
714elDynAttrNS' :: forall t m a. MonadWidget t m => Maybe String -> String -> Dynamic t (Map String String) -> m a -> m (El t, a)
715elDynAttrNS' mns elementTag attrs = elWith' elementTag $
716 def & namespace .~ mns
717 & elConfig_attributes .~ attrs
719{-# INLINABLE elDynAttr' #-}
720elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
721elDynAttr' elementTag attrs = elWith' elementTag $ def & elConfig_attributes .~ attrs
723{-# INLINABLE elAttr #-}
724elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
725elAttr elementTag attrs = elWith elementTag $ def & attributes .~ attrs
727{-# INLINABLE el' #-}
728el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
729el' elementTag = elWith' elementTag def
731{-# INLINABLE elAttr' #-}
732elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
733elAttr' elementTag attrs = elWith' elementTag $ def & attributes .~ attrs
735{-# INLINABLE elDynAttr #-}
736elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
737elDynAttr elementTag attrs = elWith elementTag $ def & elConfig_attributes .~ attrs
739{-# INLINABLE el #-}
740el :: forall t m a. MonadWidget t m => String -> m a -> m a
741el elementTag = elWith elementTag def
743elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
744elClass elementTag c = elWith elementTag $ def & attributes .~ "class" =: c
746--------------------------------------------------------------------------------
747-- Copied and pasted from Reflex.Widget.Class
748--------------------------------------------------------------------------------
750-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
751-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
752list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
753list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
755-- | Create a dynamically-changing set of widgets from a Dynamic list.
756simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
757simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs
759elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
760elDynHtml' elementTag html = do
761 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
762 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
763 addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
764 wrapElement defaultDomEventHandler e
766elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
767elDynHtmlAttr' elementTag attrs html = do
768 e <- buildEmptyElement elementTag attrs
769 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
770 addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
771 wrapElement defaultDomEventHandler e
773data Link t
774 = Link { _link_clicked :: Event t ()
775 }
777class HasAttributes a where
778 type Attrs a :: *
779 attributes :: Lens' a (Attrs a)
781instance HasAttributes (ElConfig attrs) where
782 type Attrs (ElConfig attrs) = attrs
783 attributes = elConfig_attributes
785class HasNamespace a where
786 namespace :: Lens' a (Maybe String)
788instance HasNamespace (ElConfig attrs) where
789 namespace = elConfig_namespace
791class HasDomEvent t a where
792 domEvent :: EventName en -> a -> Event t (EventResultType en)
794instance Reflex t => HasDomEvent t (El t) where
795 domEvent en e = fmap unEventResult $ Reflex.select (_el_events e) (WrapArg en)
797linkClass :: MonadWidget t m => String -> String -> m (Link t)
798linkClass s c = do
799 (l,_) <- elAttr' "a" ("class" =: c) $ text s
800 return $ Link $ domEvent Click l
802link :: MonadWidget t m => String -> m (Link t)
803link s = linkClass s ""
805button :: MonadWidget t m => String -> m (Event t ())
806button s = do
807 (e, _) <- elAttr' "button" (Map.singleton "type" "button") $ text s
808 return $ domEvent Click e
810newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
812workflow :: forall t m a. MonadWidget t m => Workflow t m a -> m (Dynamic t a)
813workflow w0 = do
814 rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ fmap snd $ current eResult
815 mapDyn fst eResult
817workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
818workflowView w0 = do
819 rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
820 eReplace <- liftM switch $ hold never $ fmap snd eResult
821 return $ fmap fst eResult
823mapWorkflow :: (MonadWidget t m) => (a -> b) -> Workflow t m a -> Workflow t m b
824mapWorkflow f (Workflow x) = Workflow (fmap (\(v,e) -> (f v, fmap (mapWorkflow f) e)) x)
826divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
827divClass = elClass "div"
829dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
830dtdd h w = do
831 el "dt" $ text h
832 el "dd" $ w
834blank :: forall t m. MonadWidget t m => m ()
835blank = return ()
837-- | A widget to display a table with static columns and dynamic rows.
838tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k)
839 => String -- ^ Class applied to <table> element
840 -> [(String, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
841 -> Dynamic t (Map k r) -- ^ Map from row key to row value
842 -> (k -> m (Dynamic t (Map String String))) -- ^ Function to compute <tr> element attributes from row key
843 -> m (Dynamic t (Map k (El t, [v]))) -- ^ Map from row key to (El, list of widget return values)
844tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
845 elAttr "table" (Map.singleton "class" klass) $ do
846 el "thead" $ el "tr" $ do
847 mapM_ (\(h, _) -> el "th" $ text h) cols
848 el "tbody" $ do
849 listWithKey dRows (\k r -> do
850 dAttrs <- rowAttrs k
851 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
853--TODO preselect a tab on open
854-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
855-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
856-- the corresponding child and hides all others.
857tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k)
858 => String -- ^ Class applied to <ul> element
859 -> String -- ^ Class applied to currently active <li> element
860 -> Map k (String, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)
861 -> m ()
862tabDisplay ulClass activeClass tabItems = do
863 rec dCurrentTab <- holdDyn Nothing (updated dTabClicks)
864 dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do
865 tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< mapDyn (== (Just k)) dCurrentTab) tabItems
866 let eTabClicks :: Event t k = leftmost tabClicksList
867 holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))
868 divClass "" $ do
869 let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems
870 _ <- listWithKey dTabs (\k dTab -> do
871 dAttrs <- mapDyn (\sel -> do
872 let t1 = listToMaybe $ Map.keys tabItems
873 if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab
874 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
875 return ()
876 where
877 headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k)
878 headerBarLink x k dBool = do
879 dAttributes <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) dBool
880 elDynAttr "li" dAttributes $ do
881 a <- link x
882 return $ fmap (const k) (_link_clicked a)
884-- | 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.
885unsafePlaceElement :: MonadWidget t m => Element -> m (El t)
886unsafePlaceElement e = do
887 p <- askParent
888 _ <- appendChild p $ Just e
889 wrapElement defaultDomEventHandler e
891deriveGEq ''EventName
892deriveGCompare ''EventName
894--------------------------------------------------------------------------------
895-- Deprecated functions
897{-# DEPRECATED _el_clicked "Use `domEvent Click` instead" #-}
898_el_clicked :: Reflex t => El t -> Event t ()
899_el_clicked = domEvent Click
901{-# DEPRECATED _el_keypress "Use `domEvent Keypress` instead" #-}
902_el_keypress :: Reflex t => El t -> Event t Int
903_el_keypress = domEvent Keypress
905{-# DEPRECATED _el_scrolled "Use `domEvent Scroll` instead" #-}
906_el_scrolled :: Reflex t => El t -> Event t Int
907_el_scrolled = domEvent Scroll