git.iko.soy/reflex-dom
on develop help sign in
Merge branch 'develop' into fix-dyn-pattern-match
cbc09e3Ali Abrar
Quickref.mdnew file+204
compare with develop
unifiedsplit
@@ -0,0 +1,204 @@
1+# Reflex-Dom Quick(ish) Reference
2+
3+## Typeclasses
4+
5+Function signatures have been simplified. The 't' type parameter and many typeclass constraints are removed, and annotations are added regarding the monad of the result type (See the Reflex Quickstart for more discussion). Annotations:
6+
7+```haskell
8+[ ] -- Pure function
9+[W] -- Function runs in any monad supporting MonadWidget
10+[I] -- Function runs in IO
11+```
12+
13+Functions from Reflex that run in MonadSample or MonadHold context ([S] or [H]) will also run in [W].
14+
15+## Creating widgets (DOM elements hooked into the FRP system)
16+
17+### Basic widgets
18+
19+These functions generally take an element tag (such as "div", "h1", etc) and a child widget, and produce a widget of the given type containing the child. Some of these functions return data of type `El`, which is a handle to the created DOM element along with a set of potential Events that might occur on that element.
20+
21+Widgets may return any type (this is 'a' in many of the functions below). Often this will be an Event carrying user interactions with the widget.
22+
23+```haskell
24+-- Simplest form. Create a widget of given type containing the given child.
25+-- Return whatever the child returns.
26+[W] el :: String -> m a -> m a
27+
28+-- This version returns the 'El' as well.
29+[W] el' :: String -> m a -> m (El, a)
30+
31+-- These two additionally apply attributes to the element, such as ("class" =: "blah")
32+[W] elAttr :: String -> Map String String -> m a -> m a
33+[W] elAttr' :: String -> Map String String -> m a -> m (El, a)
34+
35+-- As above, but now the attribute map is Dynamic
36+[W] elDynAttr :: String -> Dynamic (Map String String) -> m a -> m a
37+[W] elDynAttr' :: String -> Dynamic (Map String String) -> m a -> m (El, a)
38+
39+-- Shortcut for elAttr when you only want to set the "class" attribute.
40+[W] elClass :: String -> String -> m a -> m a
41+
42+-- Even shorter-cut for above when element type is "div". Create a div of given class.
43+[W] divClass :: String -> m a -> m a
44+
45+-- Create a widget of given type with arbitrary, Dymamic HTML inside.
46+[W] elDynHtml' :: String -> Dynamic String -> m El
47+[W] elDynHtmlAttr' :: String -> Map String String -> Dynamic String -> m El
48+
49+-- Shortcut for elDynHtml' where the type is "div" and you don't need the 'El'.
50+[W] dynHtml :: Dynamic String -> m ()
51+
52+-- Create a static text element
53+[W] text :: String -> m ()
54+
55+-- Create a dynamic text element
56+[W] dynText :: Dynamic String -> m ()
57+[W] display :: Show a => Dynamic a -> m ()
58+
59+-- Create a "button" element with given label, return onClick Event
60+[W] button :: String -> m (Event ())
61+
62+-- Empty widget
63+[W] blank :: m ()
64+```
65+
66+### Dynamic widgets
67+
68+In the Dynamic cases so far, the *content* of a widget is dynamic but the *definition* of the widget is static. The functions below enable the definition and/or structure of the widget itself to change over time.
69+
70+Note the "list" functions do not imply particular HTML tags (ul, li, etc), though the widgets they create can have those tags if you construct them appropriately.
71+
72+```haskell
73+-- Create a dynamically-redefined widget from a Dynamic of widget actions.
74+[W] dyn :: Dynamic (m a) -> m (Event a)
75+
76+-- Same as dyn, but takes initial value and an update Event instead of a Dynamic.
77+[W] widgetHold :: m a -> Event (m a) -> m (Dynamic a)
78+
79+-- Turn a Dynamic key/value map into a set of dynamically-changing widgets.
80+[W] listWithKey :: Ord k =>
81+ Dynamic (Map k v) -> (k -> Dynamic v -> m a ) -> m (Dynamic (Map k a))
82+
83+-- Same as above where the widget constructor doesn't care about the key.
84+[W] list :: Ord k =>
85+ Dynamic (Map k v) -> ( Dynamic v -> m a ) -> m (Dynamic (Map k a))
86+
87+-- Even simpler version where there are no keys and we just use a list.
88+[W] simpleList ::
89+ Dynamic [v] -> ( Dynamic v -> m a ) -> m (Dynamic [a])
90+
91+-- Like listWithKey specialized for widgets returning (Event a).
92+[W] listViewWithKey :: Ord k =>
93+ Dynamic (Map k v) -> (k -> Dynamic v -> m (Event a)) -> m (Event (Map k a))
94+
95+-- Create a dynamically-changing set of widgets, one of which is selected at any time.
96+[W] selectViewListWithKey_ :: Ord k => Dynamic k ->
97+ Dynamic (Map k v) -> (k -> Dynamic v -> Dynamic Bool -> m (Event a)) -> m (Event k)
98+
99+-- Same as listWithKey, but takes initial values and an updates Event instead of a Dynamic.
100+[W] listWithKey' :: Ord k =>
101+ Map k v -> Event (Map k (Maybe v)) -> (k -> v -> Event v -> m a) -> m (Dynamic (Map k a))
102+```
103+
104+### Utility widgets
105+
106+These are useful widgets that are implemented (or could be implemented) in terms of the low-level widgets above.
107+
108+Some of these widget builders take a configuration record and return a record containing Events or other useful data associated with the created widget (similar to 'El'). The configuration records have default values, so you can just supply 'def'. See Reflex/Dom/Widget/Input.hs for record fields (Lenses are provided).
109+
110+```haskell
111+-- Text input.
112+[W] textInput :: TextInputConfig -> m TextInput
113+[ ] textInputGetEnter :: TextInput -> Event ()
114+[W] textArea :: TextAreaConfig -> m TextArea
115+
116+-- Checkbox. The Bool supplies the initial state.
117+[W] checkbox :: Bool -> CheckboxConfig -> m Checkbox
118+
119+-- Dropdown with Dynamic options. First argument is initial state.
120+[W] dropdown :: (Ord k, Show k, Read k) =>
121+ k -> Dynamic (Map k String) -> DropdownConfig k -> m (Dropdown k)
122+
123+-- Table with static columns and dynamic rows.
124+[W] tableDynAttr :: ... -- See Reflex.Dom.Widget.Basic
125+
126+-- Tabbed view that shows only one of its child widgets at a time.
127+[W] tabDisplay :: (Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
128+
129+-- Widget to efficiently display long scrolling lists.
130+[W] virtualListWithSelection :: ... -- See Reflex.Dom.Widget.Lazy
131+```
132+
133+## Connecting to the real world (I/O)
134+
135+### Connecting to DOM events
136+
137+```haskell
138+-- Extract the specified Event from an 'El'. See Reflex.Dom.Widget.Basic
139+[ ] domEvent :: EventName en -> El -> Event (EventResultType en)
140+```
141+
142+### Performing arbitrary I/O in response to Events
143+
144+```haskell
145+-- Run side-effecting actions in Event when it occurs; returned Event contains
146+-- results. Side effects run in (WidgetHost m) monad, which includes [S] and [H]
147+-- and can also do I/O via liftIO
148+[W] performEvent :: Event ( WidgetHost m a) -> m (Event a)
149+
150+-- Just run side-effects; no return Event
151+[W] performEvent_ :: Event ( WidgetHost m ()) -> m ()
152+
153+-- Actions run asynchronously; actions are given a callback to send return values
154+[W] performEventAsync :: Event ((a -> IO ()) -> WidgetHost m ()) -> m (Event a)
155+```
156+
157+### XMLHttpRequest
158+
159+Convenience functions for XMLHttpRequest. see Reflex.Dom.Xhr
160+
161+```haskell
162+-- Given method, URL, and config record (with default instance), construct a request.
163+[ ] xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
164+
165+-- Given Event of requests, issue them and produce Event of responses.
166+[W] performRequestAsync :: Event XhrRequest -> m (Event XhrResponse)
167+
168+-- Issue a collection of requests, wait for them ALL to complete, return collected results.
169+[W] performRequestsAsync :: Traversable f => Event (f XhrRequest) -> m (Event (f XhrResponse))
170+
171+-- Convenience function to decode JSON-encoded responses.
172+[ ] decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
173+
174+-- Simplified interface to "GET" URLs and return decoded results.
175+[W] getAndDecode :: FromJSON a => Event String -> m (Event (Maybe a))
176+```
177+
178+### Time
179+
180+```haskell
181+-- Create Event at given interval with given basis time.
182+[W] tickLossy :: NominalDiffTime -> UTCTime -> m (Event t TickInfo)
183+
184+-- Delay an Event's occurrences by a given amount in seconds.
185+[W] delay :: NominalDiffTime -> Event t a -> m (Event t a)
186+```
187+
188+## Startup
189+
190+```haskell
191+-- Reflex-Dom entry point. Takes a monadic widget-building action of lengthy
192+-- type and turns it into an IO action.
193+[I] mainWidget ::
194+ Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()
195+[I] mainWidgetWithHead ::
196+ Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () ->
197+ Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()
198+[I] mainWidgetWithCss ::
199+ ByteString ->
200+ Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()
201+
202+-- One-shot Event that is triggered once all initial widgets are built
203+[W] getPostBuild :: m (Event ())
204+```
default.nix+1−1
@@ -8,7 +8,7 @@
8
8
9mkDerivation {
9mkDerivation {
10 pname = "reflex-dom";
10 pname = "reflex-dom";
11− version = "0.1";
11+ version = "0.2";
12 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
12 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
13 buildDepends = [
13 buildDepends = [
14 reflex
14 reflex
reflex-dom.cabal+9−6
@@ -1,13 +1,13 @@
1Name: reflex-dom
1Name: reflex-dom
2Version: 0.2
2Version: 0.2
3−Synopsis: Glitch-free Functional Reactive Web Apps
3+Synopsis: Functional Reactive Web Apps with Reflex
4Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine
4Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine
5License: BSD3
5License: BSD3
6License-file: LICENSE
6License-file: LICENSE
7Author: Ryan Trinkle
7Author: Ryan Trinkle
8Maintainer: ryan.trinkle@gmail.com
8Maintainer: ryan.trinkle@gmail.com
9Stability: Experimental
9Stability: Experimental
10−Category: FRP
10+Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface
11Build-type: Simple
11Build-type: Simple
12Cabal-version: >=1.9.2
12Cabal-version: >=1.9.2
13-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367
13-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367
@@ -27,10 +27,10 @@ library
27 semigroups == 0.16.*,
27 semigroups == 0.16.*,
28 mtl >= 2.1 && < 2.3,
28 mtl >= 2.1 && < 2.3,
29 containers == 0.5.*,
29 containers == 0.5.*,
30− these == 0.4.*,
30+ these >= 0.4,
31 ref-tf == 0.4.*,
31 ref-tf == 0.4.*,
32 random == 1.1.*,
32 random == 1.1.*,
33− transformers == 0.4.*,
33+ transformers == 0.3.* || == 0.4.*,
34 lens >= 4.7 && < 4.10,
34 lens >= 4.7 && < 4.10,
35 ghcjs-dom >= 0.1.1.3 && < 0.2,
35 ghcjs-dom >= 0.1.1.3 && < 0.2,
36 safe == 0.3.*,
36 safe == 0.3.*,
@@ -38,7 +38,7 @@ library
38 bytestring == 0.10.*,
38 bytestring == 0.10.*,
39 data-default == 0.5.*,
39 data-default == 0.5.*,
40 aeson >= 0.8 && < 0.10,
40 aeson >= 0.8 && < 0.10,
41− time == 1.5.*,
41+ time == 1.4.* || == 1.5.*,
42 exception-transformers == 0.4.*,
42 exception-transformers == 0.4.*,
43 directory == 1.2.*,
43 directory == 1.2.*,
44 dependent-sum-template >= 0.0.0.4 && < 0.1,
44 dependent-sum-template >= 0.0.0.4 && < 0.1,
@@ -77,5 +77,8 @@ library
77 Reflex.Dom.Xhr.Foreign
77 Reflex.Dom.Xhr.Foreign
78
78
79 other-extensions: TemplateHaskell
79 other-extensions: TemplateHaskell
80− ghc-prof-options: -fprof-auto
81 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
80 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
81+
82+source-repository head
83+ type: git
84+ location: https://github.com/ryantrinkle/reflex
src-ghc/Reflex/Dom/Internal/Foreign.hs+1−2
@@ -13,7 +13,6 @@ import Graphics.UI.Gtk.WebKit.WebSettings
13import Graphics.UI.Gtk.WebKit.WebFrame
13import Graphics.UI.Gtk.WebKit.WebFrame
14import Graphics.UI.Gtk.WebKit.WebInspector
14import Graphics.UI.Gtk.WebKit.WebInspector
15import Data.List
15import Data.List
16−import Data.String
17import System.Directory
16import System.Directory
18
17
19makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()
18makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()
@@ -39,7 +38,7 @@ makeDefaultWebView userAgentKey main = do
39 _ <- webView `on` loadFinished $ \_ -> do
38 _ <- webView `on` loadFinished $ \_ -> do
40 main webView --TODO: Should probably only do this once
39 main webView --TODO: Should probably only do this once
41 inspector <- webViewGetInspector webView
40 inspector <- webViewGetInspector webView
42− _ <- inspector `on` inspectWebView $ \wv -> do
41+ _ <- inspector `on` inspectWebView $ \_ -> do
43 inspectorWindow <- windowNew
42 inspectorWindow <- windowNew
44 windowSetDefaultSize inspectorWindow 900 600
43 windowSetDefaultSize inspectorWindow 900 600
45 inspectorScrollWin <- scrolledWindowNew Nothing Nothing
44 inspectorScrollWin <- scrolledWindowNew Nothing Nothing
src/Reflex/Dom/Time.hs+11−3
@@ -1,6 +1,4 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
1+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, ScopedTypeVariables #-}
2−{-# LANGUAGE TypeFamilies #-}
3−
4module Reflex.Dom.Time where
2module Reflex.Dom.Time where
5
3
6import Reflex
4import Reflex
@@ -49,6 +47,7 @@ tickLossyFrom dt t0 e = performEventAsync $ fmap callAtNextInterval e
49 threadDelay $ ceiling $ (dt - alreadyElapsed) * 1000000
47 threadDelay $ ceiling $ (dt - alreadyElapsed) * 1000000
50 cb $ TickInfo t n alreadyElapsed
48 cb $ TickInfo t n alreadyElapsed
51
49
50+-- | Delay an Event's occurrences by a given amount in seconds.
52delay :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)
51delay :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)
53delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
52delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
54 threadDelay $ ceiling $ dt * 1000000
53 threadDelay $ ceiling $ dt * 1000000
@@ -155,3 +154,12 @@ inhomogeneousPoisson
155 -> m (Event t TickInfo)
154 -> m (Event t TickInfo)
156inhomogeneousPoisson rnd rate maxRate t0 =
155inhomogeneousPoisson rnd rate maxRate t0 =
157 inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
156 inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
157+
158+-- | Block occurrences of an Event until th given number of seconds elapses without
159+-- the Event firing, at which point the last occurrence of the Event will fire.
160+debounce :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)
161+debounce dt e = do
162+ n :: Dynamic t Integer <- count e
163+ let tagged = attachDynWith (,) n e
164+ delayed <- delay dt tagged
165+ return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed
src/Reflex/Dom/Widget/Basic.hs+266−197
@@ -21,7 +21,7 @@ import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence
21import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)
21import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)
22import GHCJS.DOM.Node
22import GHCJS.DOM.Node
23import GHCJS.DOM.UIEvent
23import GHCJS.DOM.UIEvent
24−import GHCJS.DOM.EventM (event, EventM)
24+import GHCJS.DOM.EventM (event, EventM, stopPropagation)
25import GHCJS.DOM.Document
25import GHCJS.DOM.Document
26import GHCJS.DOM.Element
26import GHCJS.DOM.Element
27import GHCJS.DOM.HTMLElement
27import GHCJS.DOM.HTMLElement
@@ -34,11 +34,25 @@ import Data.Maybe
34import Data.GADT.Compare.TH
34import Data.GADT.Compare.TH
35import Data.Bitraversable
35import Data.Bitraversable
36import GHCJS.DOM.MouseEvent
36import GHCJS.DOM.MouseEvent
37+import Data.IORef
38+import Data.Default
37
39
38type AttributeMap = Map String String
40type AttributeMap = Map String String
39
41
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+
40data El t
54data El t
41− = El { _el_element :: HTMLElement
55+ = El { _el_element :: Element
42 , _el_events :: EventSelector t (WrapArg EventResult EventName)
56 , _el_events :: EventSelector t (WrapArg EventResult EventName)
43 }
57 }
44
58
@@ -58,22 +72,30 @@ instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
58 forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
72 forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
59 imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
73 imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
60
74
61−buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement
75+buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m Element
62−buildEmptyElement elementTag attrs = do
76+buildEmptyElementNS mns elementTag attrs = do
63 doc <- askDocument
77 doc <- askDocument
64 p <- askParent
78 p <- askParent
79+ Just e <- liftIO $ case mns of
65− Just e <- liftIO $ documentCreateElement doc elementTag
80+ Nothing -> documentCreateElement doc elementTag
81+ Just ns -> documentCreateElementNS doc ns elementTag
66 addAttributes attrs e
82 addAttributes attrs e
67 _ <- liftIO $ nodeAppendChild p $ Just e
83 _ <- 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
69
88
70-- 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
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
71−buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)
90+buildElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m a -> m (Element, a)
72−buildElement elementTag attrs child = do
91+buildElementNS mns elementTag attrs child = do
73− e <- buildEmptyElement elementTag attrs
92+ e <- buildEmptyElementNS mns elementTag attrs
74 result <- subWidget (toNode e) child
93 result <- subWidget (toNode e) child
75 return (e, result)
94 return (e, result)
76
95
96+buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (Element, a)
97+buildElement = buildElementNS Nothing
98+
77namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
99namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
78namedNodeMapGetNames self = do
100namedNodeMapGetNames self = do
79 l <- namedNodeMapGetLength self
101 l <- namedNodeMapGetLength self
@@ -106,41 +128,33 @@ display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()
106display a = dynText =<< mapDyn show a
128display a = dynText =<< mapDyn show a
107
129
108--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
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.
109dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
134dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
110dyn child = do
135dyn child = do
111− startPlaceholder <- text' ""
136+ postBuild <- getPostBuild
112− endPlaceholder <- text' ""
137+ let newChild = leftmost [updated child, tag (current child) postBuild]
113− (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
138+ liftM snd $ widgetHoldInternal (return ()) newChild
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
135
139
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.
136widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
143widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
137widgetHold child0 newChild = do
144widgetHold 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
138 startPlaceholder <- text' ""
150 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
140 endPlaceholder <- text' ""
154 endPlaceholder <- text' ""
141 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
155 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
142 performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack
156 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
144 addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?
158 addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?
145 doc <- askDocument
159 doc <- askDocument
146 runWidget <- getRunWidget
160 runWidget <- getRunWidget
@@ -149,91 +163,77 @@ widgetHold child0 newChild = do
149 (result, postBuild, voidActions) <- runWidget df c
163 (result, postBuild, voidActions) <- runWidget df c
150 scheduleFollowup newChildBuiltTriggerRef (result, voidActions)
164 scheduleFollowup newChildBuiltTriggerRef (result, voidActions)
151 postBuild
165 postBuild
152− mp <- liftIO $ nodeGetParentNode endPlaceholder
166+ 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)
167+ forM_ mp' $ \p' -> liftIO $ nodeInsertBefore p' (Just df) (Just endPlaceholder)
157− return ()
158 return ()
168 return ()
159 addVoidAction $ ffor newChild $ \c -> do
169 addVoidAction $ ffor newChild $ \c -> do
160 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
170 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
161 build c
171 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
163
185
164--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
186--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))
166listWithKey vals mkChild = do
188listWithKey vals mkChild = do
167− doc <- askDocument
189+ postBuild <- getPostBuild
168− endPlaceholder <- text' ""
190+ rec sentVals :: Dynamic t (Map k v) <- foldDyn (flip applyMap) Map.empty changeVals
169− (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
191+ let changeVals :: Event t (Map k (Maybe v))
170− performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
192+ changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost
171− children <- hold Map.empty newChildren
193+ [ updated vals
172− addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
194+ , tag (current vals) postBuild
173− runWidget <- getRunWidget
195+ ]
174− let buildChild df k v = runWidget df $ do
196+ listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do
175− childStart <- text' ""
176− result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
197+ mkChild k =<< holdDyn v0 dv
177− childEnd <- text' ""
198+
178− return (result, (childStart, childEnd))
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)" #-}
179− schedulePostBuild $ do
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))
180− Just df <- liftIO $ documentCreateDocumentFragment doc
201+listWithKey' = listWithKeyShallowDiff
181− curVals <- sample $ current vals
202+
182− initialState <- iforM curVals $ \k v -> do
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.
183− (result, postBuild, voidAction) <- buildChild df k v
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))
184− return ((result, voidAction), postBuild)
205+listWithKeyShallowDiff initialVals valsChanged mkChild = do
185− scheduleFollowup newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
206+ let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
186− sequence_ $ fmap snd initialState
207+ sentVals <- foldDyn (flip applyMap) Map.empty $ fmap (fmap (fmap (\_ -> ()))) valsChanged
187− mp <- liftIO $ nodeGetParentNode endPlaceholder
208+ let relevantDiff diff _ = case diff of
188− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
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
189− return ()
210+ Just _ -> Nothing -- We don't want to let spurious re-creations of items through
190− addVoidAction $ flip fmap (updated vals) $ \newVals -> do
211+ listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantDiff)) (current sentVals) valsChanged) $ \k v ->
191− curState <- sample children
212+ mkChild k v $ select childValChangedSelector $ Const2 k
192− --TODO: Should we remove the parent from the DOM first to avoid reflows?
213+
193− (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
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.
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+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))
215−listWithKey' initialVals valsChanged mkChild = do
216+listHoldWithKey initialVals valsChanged mkChild = do
216 doc <- askDocument
217 doc <- askDocument
217 endPlaceholder <- text' ""
218 endPlaceholder <- text' ""
218 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
219 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
219-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
220-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
220 runWidget <- getRunWidget
221 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
224 wrapChild k v = do
223 wrapChild k v = do
225 childStart <- text' ""
224 childStart <- text' ""
226− result <- mkChild k v $ select childValChangedSelector $ Const2 k
225+ result <- mkChild k v
227 childEnd <- text' ""
226 childEnd <- text' ""
228 return (result, (childStart, childEnd))
227 return (result, (childStart, childEnd))
229 Just dfOrig <- liftIO $ documentCreateDocumentFragment doc
228 Just dfOrig <- liftIO $ documentCreateDocumentFragment doc
230 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
229 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
231 children <- holdDyn initialState newChildren
231 children <- holdDyn initialState newChildren
232 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
232 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
233 mpOrig <- liftIO $ nodeGetParentNode endPlaceholder
233 mpOrig <- liftIO $ nodeGetParentNode endPlaceholder
234 forM_ mpOrig $ \pOrig -> liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)
234 forM_ mpOrig $ \pOrig -> liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)
235 addVoidAction $ flip fmap valsChanged $ \newVals -> do
235 addVoidAction $ flip fmap valsChanged $ \newVals -> do
236− curState <- sample $ current children
236+ curState <- liftIO $ readIORef stateRef
237 --TODO: Should we remove the parent from the DOM first to avoid reflows?
237 --TODO: Should we remove the parent from the DOM first to avoid reflows?
238 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
238 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
239 These ((_, (start, end)), _) Nothing -> do -- Deleting child
239 These ((_, (start, end)), _) Nothing -> do -- Deleting child
@@ -262,66 +262,26 @@ listWithKey' initialVals valsChanged mkChild = do
262 return $ Just s
262 return $ Just s
263 This state -> do -- No change
263 This state -> do -- No change
264 return $ Just state
264 return $ Just state
265+ liftIO $ writeIORef stateRef newState
265− scheduleFollowup newChildrenTriggerRef newState
266+ runFrameWithTriggerRef newChildrenTriggerRef newState
266 postBuild
267 postBuild
267 mapDyn (fmap (fst . fst)) children
268 mapDyn (fmap (fst . fst)) children
268
269
269--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
270--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'.
270listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
273listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
271listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
274listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
272
275
273listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
276listViewWithKey' :: (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
277+listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild
275− doc <- askDocument
278+
276− endPlaceholder <- text' ""
279+-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
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)
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.
325selectViewListWithKey_ selection vals mkChild = do
285selectViewListWithKey_ selection vals mkChild = do
326 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
286 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
327 selectChild <- listWithKey vals $ \k v -> do
287 selectChild <- listWithKey vals $ \k v -> do
@@ -581,6 +541,8 @@ type family EventResultType (en :: EventTag) :: * where
581 EventResultType 'ClickTag = ()
541 EventResultType 'ClickTag = ()
582 EventResultType 'DblclickTag = ()
542 EventResultType 'DblclickTag = ()
583 EventResultType 'KeypressTag = Int
543 EventResultType 'KeypressTag = Int
544+ EventResultType 'KeydownTag = Int
545+ EventResultType 'KeyupTag = Int
584 EventResultType 'ScrollTag = Int
546 EventResultType 'ScrollTag = Int
585 EventResultType 'MousemoveTag = (Int, Int)
547 EventResultType 'MousemoveTag = (Int, Int)
586 EventResultType 'MousedownTag = (Int, Int)
548 EventResultType 'MousedownTag = (Int, Int)
@@ -590,6 +552,36 @@ type family EventResultType (en :: EventTag) :: * where
590 EventResultType 'FocusTag = ()
552 EventResultType 'FocusTag = ()
591 EventResultType 'BlurTag = ()
553 EventResultType 'BlurTag = ()
592 EventResultType 'ChangeTag = ()
554 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 = ()
593
585
594wrapDomEventsMaybe :: (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))
586wrapDomEventsMaybe :: (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))
595wrapDomEventsMaybe element handlers = do
587wrapDomEventsMaybe element handlers = do
@@ -616,13 +608,15 @@ getKeyEvent = do
616getMouseEventCoords :: EventM MouseEvent e (Int, Int)
608getMouseEventCoords :: EventM MouseEvent e (Int, Int)
617getMouseEventCoords = do
609getMouseEventCoords = do
618 e <- event
610 e <- event
619− liftIO $ bisequence (mouseEventGetX e, mouseEventGetY e)
611+ liftIO $ bisequence (mouseEventGetClientX e, mouseEventGetClientY e)
620
612
621defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))
613defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))
622defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
614defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
623 Click -> return ()
615 Click -> return ()
624 Dblclick -> return ()
616 Dblclick -> return ()
625 Keypress -> getKeyEvent
617 Keypress -> getKeyEvent
618+ Keydown -> getKeyEvent
619+ Keyup -> getKeyEvent
626 Scroll -> liftIO $ elementGetScrollTop e
620 Scroll -> liftIO $ elementGetScrollTop e
627 Mousemove -> getMouseEventCoords
621 Mousemove -> getMouseEventCoords
628 Mouseup -> getMouseEventCoords
622 Mouseup -> getMouseEventCoords
@@ -632,92 +626,153 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
632 Focus -> return ()
626 Focus -> return ()
633 Blur -> return ()
627 Blur -> return ()
634 Change -> return ()
628 Change -> return ()
635−
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+
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)
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)
637−wrapElement e = do
661+wrapElement eh e = do
638− es <- wrapDomEventsMaybe e $ defaultDomEventHandler e
662+ es <- wrapDomEventsMaybe e $ eh e
639 return $ El e es
663 return $ El e es
640
664
641−elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
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)
642−elDynAttr' elementTag attrs child = do
680+elWith' elementTag cfg child = do
643− (e, result) <- buildElement elementTag attrs child
681+ (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
644− e' <- wrapElement e
682+ e' <- wrapElement defaultDomEventHandler e
645 return (e', result)
683 return (e', result)
646
684
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+
647{-# INLINABLE elAttr #-}
706{-# INLINABLE elAttr #-}
648elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
707elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
649−elAttr elementTag attrs child = do
708+elAttr elementTag attrs = elWith elementTag $ def & attributes .~ attrs
650− (_, result) <- buildElement elementTag attrs child
651− return result
652
709
653{-# INLINABLE el' #-}
710{-# INLINABLE el' #-}
654el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
711el' :: 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
656
713
657{-# INLINABLE elAttr' #-}
714{-# INLINABLE elAttr' #-}
658elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
715elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
659−elAttr' elementTag attrs child = do
716+elAttr' elementTag attrs = elWith' elementTag $ def & attributes .~ attrs
660− (e, result) <- buildElement elementTag attrs child
661− e' <- wrapElement e
662− return (e', result)
663
717
664{-# INLINABLE elDynAttr #-}
718{-# INLINABLE elDynAttr #-}
665elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
719elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
666−elDynAttr elementTag attrs child = do
720+elDynAttr elementTag attrs = elWith elementTag $ def & elConfig_attributes .~ attrs
667− (_, result) <- buildElement elementTag attrs child
668− return result
669
721
670{-# INLINABLE el #-}
722{-# INLINABLE el #-}
671el :: forall t m a. MonadWidget t m => String -> m a -> m a
723el :: 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
673
725
674elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
726elClass :: 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
676
728
677--------------------------------------------------------------------------------
729--------------------------------------------------------------------------------
678-- Copied and pasted from Reflex.Widget.Class
730-- Copied and pasted from Reflex.Widget.Class
679--------------------------------------------------------------------------------
731--------------------------------------------------------------------------------
680
732
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.
681list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
735list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
682list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
736list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
683
737
738+-- | Create a dynamically-changing set of widgets from a Dynamic list.
684simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
739simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
685simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs
740simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs
686
741
687elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
742elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
688elDynHtml' elementTag html = do
743elDynHtml' elementTag html = do
689 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
744 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
745+ let h = castToHTMLElement e
690− schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
746+ schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
691− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
747+ addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
692− wrapElement e
748+ wrapElement defaultDomEventHandler e
693
749
694elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
750elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
695elDynHtmlAttr' elementTag attrs html = do
751elDynHtmlAttr' elementTag attrs html = do
696 e <- buildEmptyElement elementTag attrs
752 e <- buildEmptyElement elementTag attrs
753+ let h = castToHTMLElement e
697− schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
754+ schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
698− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
755+ addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
699− wrapElement e
756+ wrapElement defaultDomEventHandler 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−-}
716
757
717data Link t
758data Link t
718 = Link { _link_clicked :: Event t ()
759 = Link { _link_clicked :: Event t ()
719 }
760 }
720
761
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+
721class HasDomEvent t a where
776class HasDomEvent t a where
722 domEvent :: EventName en -> a -> Event t (EventResultType en)
777 domEvent :: EventName en -> a -> Event t (EventResultType en)
723
778
@@ -761,7 +816,13 @@ dtdd h w = do
761blank :: forall t m. MonadWidget t m => m ()
816blank :: forall t m. MonadWidget t m => m ()
762blank = return ()
817blank = return ()
763
818
819+-- | A widget to display a table with static columns and dynamic rows.
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])))
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)
765tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
826tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
766 elAttr "table" (Map.singleton "class" klass) $ do
827 elAttr "table" (Map.singleton "class" klass) $ do
767 el "thead" $ el "tr" $ do
828 el "thead" $ el "tr" $ do
@@ -771,7 +832,15 @@ tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zo
771 dAttrs <- rowAttrs k
832 dAttrs <- rowAttrs k
772 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
833 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
773
834
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.
774−tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
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 ()
775tabDisplay ulClass activeClass tabItems = do
844tabDisplay ulClass activeClass tabItems = do
776 let t0 = listToMaybe $ Map.keys tabItems
845 let t0 = listToMaybe $ Map.keys tabItems
777 rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do
846 rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do
@@ -793,11 +862,11 @@ tabDisplay ulClass activeClass tabItems = do
793 return $ fmap (const k) (_link_clicked a)
862 return $ fmap (const k) (_link_clicked a)
794
863
795-- | 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.
864-- | 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)
797unsafePlaceElement e = do
866unsafePlaceElement e = do
798 p <- askParent
867 p <- askParent
799 _ <- liftIO $ nodeAppendChild p $ Just e
868 _ <- liftIO $ nodeAppendChild p $ Just e
800− wrapElement e
869+ wrapElement defaultDomEventHandler e
801
870
802deriveGEq ''EventName
871deriveGEq ''EventName
803deriveGCompare ''EventName
872deriveGCompare ''EventName
src/Reflex/Dom/Widget/Input.hs+3−10
@@ -13,7 +13,6 @@ import GHCJS.DOM.HTMLTextAreaElement
13import GHCJS.DOM.Element
13import GHCJS.DOM.Element
14import GHCJS.DOM.HTMLSelectElement
14import GHCJS.DOM.HTMLSelectElement
15import GHCJS.DOM.EventM
15import GHCJS.DOM.EventM
16−import GHCJS.DOM.UIEvent
17import GHCJS.DOM.File
16import GHCJS.DOM.File
18import GHCJS.DOM.FileList
17import GHCJS.DOM.FileList
19import Data.Monoid
18import Data.Monoid
@@ -158,17 +157,15 @@ data FileInput t
158 }
157 }
159
158
160data FileInputConfig t
159data FileInputConfig t
161− = FileInputConfig { _fileInputConfig_clearValue :: Event t ()
162− , _fileInputConfig_attributes :: Dynamic t (Map String String)
160+ = FileInputConfig { _fileInputConfig_attributes :: Dynamic t (Map String String)
163 }
161 }
164
162
165instance Reflex t => Default (FileInputConfig t) where
163instance Reflex t => Default (FileInputConfig t) where
166− def = FileInputConfig { _fileInputConfig_clearValue = never
167− , _fileInputConfig_attributes = constDyn mempty
164+ def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty
168 }
165 }
169
166
170fileInput :: MonadWidget t m => FileInputConfig t -> m (FileInput t)
167fileInput :: MonadWidget t m => FileInputConfig t -> m (FileInput t)
171−fileInput (FileInputConfig clearValue dAttrs) = do
168+fileInput (FileInputConfig dAttrs) = do
172 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "file") dAttrs
169 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "file") dAttrs
173 eChange <- wrapDomEvent e elementOnchange $ liftIO $ do
170 eChange <- wrapDomEvent e elementOnchange $ liftIO $ do
174 Just files <- htmlInputElementGetFiles e
171 Just files <- htmlInputElementGetFiles e
@@ -227,10 +224,6 @@ liftM concat $ mapM makeLenses
227 , ''Checkbox
224 , ''Checkbox
228 ]
225 ]
229
226
230−class HasAttributes a where
231− type Attrs a :: *
232− attributes :: Lens' a (Attrs a)
233−
234instance HasAttributes (TextAreaConfig t) where
227instance HasAttributes (TextAreaConfig t) where
235 type Attrs (TextAreaConfig t) = Dynamic t (Map String String)
228 type Attrs (TextAreaConfig t) = Dynamic t (Map String String)
236 attributes = textAreaConfig_attributes
229 attributes = textAreaConfig_attributes
src/Reflex/Dom/Widget/Lazy.hs+22−19
@@ -15,7 +15,7 @@ import GHCJS.DOM.Element
15
15
16-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.
16-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.
17virtualListWithSelection :: forall t m k v. (MonadWidget t m, Ord k)
17virtualListWithSelection :: forall t m k v. (MonadWidget t m, Ord k)
18− => Int -- ^ The height of the visible region in pixels
18+ => Dynamic t Int -- ^ The height of the visible region in pixels
19 -> Int -- ^ The height of each row in pixels
19 -> Int -- ^ The height of each row in pixels
20 -> Dynamic t Int -- ^ The total number of items
20 -> Dynamic t Int -- ^ The total number of items
21 -> Int -- ^ The index of the row to scroll to on initialization
21 -> Int -- ^ The index of the row to scroll to on initialization
@@ -24,37 +24,39 @@ virtualListWithSelection :: forall t m k v. (MonadWidget t m, Ord k)
24 -> Dynamic t (Map String String) -- ^ The attributes of the list
24 -> Dynamic t (Map String String) -- ^ The attributes of the list
25 -> String -- ^ The element tag for a row
25 -> String -- ^ The element tag for a row
26 -> Dynamic t (Map String String) -- ^ The attributes of each row
26 -> Dynamic t (Map String String) -- ^ The attributes of each row
27− -> (k -> Dynamic t v -> m ()) -- ^ The row child element builder
27+ -> (k -> Dynamic t (Maybe v) -> Dynamic t Bool -> m ()) -- ^ The row child element builder
28 -> Dynamic t (Map k v) -- ^ The 'Map' of items
28 -> Dynamic t (Map k v) -- ^ The 'Map' of items
29+ -> (Int -> k) -- ^ Index to Key function, used to determine position of Map elements
29 -> m (Dynamic t (Int, Int), Event t k) -- ^ A tuple containing: a 'Dynamic' of the index (based on the current scroll position) and number of items currently being rendered, and an 'Event' of the selected key
30 -> m (Dynamic t (Int, Int), Event t k) -- ^ A tuple containing: a 'Dynamic' of the index (based on the current scroll position) and number of items currently being rendered, and an 'Event' of the selected key
30−virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTag rowAttrs itemBuilder items = do
31+virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTag rowAttrs itemBuilder items indexToKey = do
31 totalHeightStyle <- mapDyn (toHeightStyle . (*) rowPx) maxIndex
32 totalHeightStyle <- mapDyn (toHeightStyle . (*) rowPx) maxIndex
32− rec (container, itemList) <- elAttr "div" outerStyle $ elAttr' "div" containerStyle $ do
33+ containerStyle <- mapDyn toContainer heightPx
34+ viewportStyle <- mapDyn toViewport heightPx
35+ rec (container, sel) <- elDynAttr "div" containerStyle $ elDynAttr' "div" viewportStyle $ do
33 currentTop <- mapDyn (listWrapperStyle . fst) window
36 currentTop <- mapDyn (listWrapperStyle . fst) window
34− (_, lis) <- elDynAttr "div" totalHeightStyle $ tagWrapper listTag listAttrs currentTop $ listWithKey itemsInWindow $ \k v -> do
37+ (_, lis) <- elDynAttr "div" totalHeightStyle $ tagWrapper listTag listAttrs currentTop $ selectViewListWithKey_ selected itemsInWindow $ \k v s -> do
35− (li,_) <- tagWrapper rowTag rowAttrs (constDyn $ toHeightStyle rowPx) $ itemBuilder k v
38+ (li,_) <- tagWrapper rowTag rowAttrs (constDyn $ toHeightStyle rowPx) $ itemBuilder k v s
36 return $ fmap (const k) (domEvent Click li)
39 return $ fmap (const k) (domEvent Click li)
37 return lis
40 return lis
41+ selected <- holdDyn (indexToKey i0) sel
42+ pb <- getPostBuild
38− scrollPosition <- holdDyn 0 $ domEvent Scroll container
43+ scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll container
44+ , fmap (const (i0 * rowPx)) pb
45+ ]
39− window <- mapDyn (findWindow heightPx rowPx) scrollPosition
46+ window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition
40− itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ take num $ drop idx $ Map.toList is) window items
47+ itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items
41 postBuild <- getPostBuild
48 postBuild <- getPostBuild
42 performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]
49 performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]
43 indexAndLength <- mapDyn snd window
50 indexAndLength <- mapDyn snd window
44− sel <- mapDyn (leftmost . Map.elems) itemList
45− return (indexAndLength, switch $ current sel)
51+ return (indexAndLength, sel)
46 where
52 where
47 toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)
53 toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)
48− outerStyle = toStyleAttr $ "position" =: "relative" <>
49− "height" =: (show heightPx <> "px")
50− containerStyle = toStyleAttr $ "overflow" =: "auto" <>
54+ toViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>
51− "position" =: "absolute" <>
52− "left" =: "0" <>
53− "right" =: "0" <>
55+ "left" =: "0" <> "right" =: "0" <> "height" =: (show h <> "px")
54− "height" =: (show heightPx <> "px")
56+ toContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (show h <> "px")
55 listWrapperStyle t = toStyleAttr $ "position" =: "relative" <>
57 listWrapperStyle t = toStyleAttr $ "position" =: "relative" <>
56 "top" =: (show t <> "px")
58 "top" =: (show t <> "px")
57− toHeightStyle h = toStyleAttr ("height" =: (show h <> "px"))
59+ toHeightStyle h = toStyleAttr ("height" =: (show h <> "px") <> "overflow" =: "hidden")
58 tagWrapper elTag attrs attrsOverride c = do
60 tagWrapper elTag attrs attrsOverride c = do
59 attrs' <- combineDyn Map.union attrsOverride attrs
61 attrs' <- combineDyn Map.union attrsOverride attrs
60 elDynAttr' elTag attrs' c
62 elDynAttr' elTag attrs' c
@@ -65,3 +67,4 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
65 preItems = min startingIndex numItems
67 preItems = min startingIndex numItems
66 in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))
68 in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))
67
69
70+
src/Reflex/Dom/Xhr.hs+6−1
@@ -1,4 +1,4 @@
1−{-# LANGUAGE TemplateHaskell, GADTs #-}
1+{-# LANGUAGE TemplateHaskell, GADTs, DeriveDataTypeable #-}
2module Reflex.Dom.Xhr
2module Reflex.Dom.Xhr
3 ( module Reflex.Dom.Xhr
3 ( module Reflex.Dom.Xhr
4 , XMLHttpRequest
4 , XMLHttpRequest
@@ -63,6 +63,7 @@ instance a ~ () => Default (XhrRequestConfig a) where
63 , _xhrRequestConfig_sendData = ()
63 , _xhrRequestConfig_sendData = ()
64 }
64 }
65
65
66+-- | Construct a request object from method, URL, and config record.
66xhrRequest :: String -> String -> XhrRequestConfig a -> XhrRequest a
67xhrRequest :: String -> String -> XhrRequestConfig a -> XhrRequest a
67xhrRequest = XhrRequest
68xhrRequest = XhrRequest
68
69
@@ -93,11 +94,13 @@ newXMLHttpRequest req cb = do
93 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
94 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
94 return xhr
95 return xhr
95
96
97+-- | Given Event of request, issue them when the Event fires. Returns Event of corresponding response.
96performRequestAsync :: (MonadWidget t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)
98performRequestAsync :: (MonadWidget t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)
97performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
99performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
98 _ <- newXMLHttpRequest r $ liftIO . cb
100 _ <- newXMLHttpRequest r $ liftIO . cb
99 return ()
101 return ()
100
102
103+-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
101performRequestsAsync :: (Traversable f, MonadWidget t m, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))
104performRequestsAsync :: (Traversable f, MonadWidget t m, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))
102performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
105performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
103 resps <- forM rs $ \r -> do
106 resps <- forM rs $ \r -> do
@@ -107,6 +110,7 @@ performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
107 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
110 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
108 return ()
111 return ()
109
112
113+-- | Simplified interface to "GET" URLs and return decoded results.
110getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))
114getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))
111getAndDecode url = do
115getAndDecode url = do
112 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
116 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
@@ -120,6 +124,7 @@ getMay f e = do
120decodeText :: FromJSON a => Text -> Maybe a
124decodeText :: FromJSON a => Text -> Maybe a
121decodeText = decode . BL.fromStrict . encodeUtf8
125decodeText = decode . BL.fromStrict . encodeUtf8
122
126
127+-- | Convenience function to decode JSON-encoded responses.
123decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
128decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
124decodeXhrResponse = join . fmap decodeText . _xhrResponse_body
129decodeXhrResponse = join . fmap decodeText . _xhrResponse_body
125
130