@@ -1,281 +1,200 @@
1−{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes, TemplateHaskell #-}
2−
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE RecursiveDo #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
313module Reflex.Dom.Widget.Basic where
414
15+import Reflex.Dom.Builder.Class
516import Reflex.Dom.Class
617import Reflex.Dom.Internal.Foreign ()
18+import Reflex.Dom.PostBuild.Class
719
8−import Prelude hiding (mapM, mapM_, sequence, sequence_)
9−import Reflex
10−import Reflex.Host.Class
20+import Control.Arrow
21+import Control.Lens hiding (children, element)
22+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
23+import Data.Align
24+import Data.Default
25+import Data.Either
26+import Data.Foldable
1127import Data.Functor.Misc
1228import Data.Map (Map)
1329import qualified Data.Map as Map
30+import Data.Maybe
31+import Data.Semigroup
1432import Data.Set (Set)
1533import qualified Data.Set as Set
16−import Data.Dependent.Sum (DSum (..))
17−import Data.Foldable
18−import Data.Traversable
19−import Control.Monad.Trans
20−import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
21−import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)
22−import GHCJS.DOM.Node
23−import GHCJS.DOM.UIEvent
24−import GHCJS.DOM.EventM (on, event, EventM, stopPropagation)
25−import GHCJS.DOM.Document
26−import GHCJS.DOM.Element as E
27−import GHCJS.DOM.Types hiding (Event)
28−import qualified GHCJS.DOM.Types as DOM (Event)
29−import GHCJS.DOM.NamedNodeMap as NNM
30−import Control.Lens hiding (element, children)
34+import Data.Text (Text)
35+import qualified Data.Text as T
3136import Data.These
32−import Data.Align
33−import Data.Maybe
34−import Data.GADT.Compare.TH
35−import Data.Bitraversable
36−import GHCJS.DOM.MouseEvent
37−import Data.IORef
38−import Data.Default
37+import Data.Traversable
38+import Prelude hiding (mapM, mapM_, sequence, sequence_)
39+import Reflex
40+
41+widgetHoldInternal :: DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
42+widgetHoldInternal child0 child' = do
43+ childResult0 <- deletable (void child') child0
44+ childResult' <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (deletable (void child')) child'
45+ return (childResult0, _placeholder_insertedAbove childResult')
46+
47+-- | Breaks the given Map into pieces based on the given Set. Each piece will contain only keys that are less than the key of the piece, and greater than or equal to the key of the piece with the next-smaller key. There will be one additional piece containing all keys from the original Map that are larger or equal to the largest key in the Set.
48+-- Either k () is used instead of Maybe k so that the resulting map of pieces is sorted so that the additional piece has the largest key.
49+-- No empty pieces will be included in the output.
50+
51+--TODO: This can probably be done more efficiently by dividing and conquering, re-using the structure of the Set instead of going through the Set linearally
52+partitionMapBySetLT :: forall k v. Ord k => Set k -> Map k v -> Map (Either k ()) (Map k v)
53+partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0
54+ where go :: [k] -> Map k v -> [(Either k (), Map k v)]
55+ go [] m = if Map.null m
56+ then []
57+ else [(Right (), m)]
58+ go (h:t) m = let (lt, eq, gt) = Map.splitLookup h m
59+ geq = maybe id (Map.insert h) eq gt
60+ in if Map.null lt
61+ then go t geq
62+ else (Left h, lt) : go t geq
63+
64+newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }
65+
66+listHoldWithKey :: forall t m k v a. (Ord k, DomBuilder t m, MonadHold t m, MonadFix m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
67+listHoldWithKey initialChildren modifyChildren buildChild = do
68+ let deleteChildSelector = fanMap $ fmap void modifyChildren
69+ liveChildren :: Dynamic t (Set k) <- foldDyn applyMapKeysSet (Map.keysSet initialChildren) modifyChildren
70+ let placeChildSelector = fanMap $ attachWith partitionMapBySetLT (current liveChildren) $ fmap (Map.mapMaybe id) modifyChildren
71+ buildAugmentedChild :: k -> v -> m (ChildResult t k a)
72+ buildAugmentedChild k v = do
73+ let delete = select deleteChildSelector $ Const2 k
74+ myCfg = def
75+ & insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Left k)
76+ & deleteSelf .~ delete
77+ ph <- placeholder myCfg
78+ result <- deletable delete $ buildChild k v
79+ return $ ChildResult (result, (fmap Just <$> _placeholder_insertedAbove ph) <> (Map.singleton k Nothing <$ _placeholder_deletedSelf ph)) --Note: we could also use the "deleted" output on deletable, if it had one; we're using this so that everything changes all at once, instead of deletions being prompt and insertions being delayed
80+ rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild
81+ augmentedResults <- foldDyn applyMap initialAugmentedResults $ newInsertedBelow <> newInsertedAbove
82+ let newInsertedAbove = switch $ mconcat . reverse . fmap (snd . unChildResult) . Map.elems <$> current augmentedResults
83+ belowAll <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Right ())
84+ let newInsertedBelow = fmap Just <$> _placeholder_insertedAbove belowAll
85+ return $ fmap (fmap (fst . unChildResult)) augmentedResults
86+
87+text :: DomBuilder t m => Text -> m ()
88+text t = void $ textNode $ def & textNodeConfig_initialContents .~ t
89+
90+dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
91+dynText t = do
92+ postBuild <- getPostBuild
93+ void $ textNode $ (def :: TextNodeConfig t) & textNodeConfig_setContents .~ leftmost
94+ [ updated t
95+ , tag (current t) postBuild
96+ ]
97+
98+display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
99+display = dynText . fmap (T.pack . show)
39100
40−type AttributeMap = Map String String
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−
54−data El t
55− = El { _el_element :: Element
56− , _el_events :: EventSelector t (WrapArg EventResult EventName)
57− }
58−
59−class Attributes m a where
60− addAttributes :: IsElement e => a -> e -> m ()
61−
62−instance MonadIO m => Attributes m AttributeMap where
63− addAttributes curAttrs e = imapM_ (setAttribute e) curAttrs
64−
65−instance 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
74−
75−buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m Element
76−buildEmptyElementNS 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
85−
86−buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m Element
87−buildEmptyElement = buildEmptyElementNS Nothing
88−
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
90−buildElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m a -> m (Element, a)
91−buildElementNS mns elementTag attrs child = do
92− e <- buildEmptyElementNS mns elementTag attrs
93− result <- subWidget (toNode e) child
94− return (e, result)
95−
96−buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (Element, a)
97−buildElement = buildElementNS Nothing
98−
99−namedNodeMapGetNames :: NamedNodeMap -> IO (Set String)
100−namedNodeMapGetNames 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
106−
107−text :: MonadWidget t m => String -> m ()
108−text = void . text'
109−
110−--TODO: Wrap the result
111−text' :: MonadWidget t m => String -> m Text
112−text' s = do
113− doc <- askDocument
114− p <- askParent
115− Just n <- createTextNode doc s
116− _ <- appendChild p $ Just n
117− return n
118−
119−dynText :: MonadWidget t m => Dynamic t String -> m ()
120−dynText 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
126−
127−display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()
128−display a = dynText =<< mapDyn show a
101+button :: DomBuilder t m => Text -> m (Event t ())
102+button t = do
103+ (e, _) <- element "button" def $ text t
104+ return $ domEvent Click e
129105
130106--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
131107-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
132108-- The returned Event of widget results occurs when the Dynamic does.
133109-- 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').
134−dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
110+dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
135111dyn child = do
136112 postBuild <- getPostBuild
137113 let newChild = leftmost [updated child, tag (current child) postBuild]
138− liftM snd $ widgetHoldInternal (return ()) newChild
114+ snd <$> widgetHoldInternal (return ()) newChild
139115
140116-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
141117-- The returned Dynamic of widget results occurs when the Event does.
142118-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
143−widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
119+widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
144120widgetHold child0 newChild = do
145121 (result0, newResult) <- widgetHoldInternal child0 newChild
146122 holdDyn result0 newResult
147123
148−widgetHoldInternal :: MonadWidget t m => m a -> Event t (m b) -> m (a, Event t b)
149−widgetHoldInternal 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)
171−
172124diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
173125diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
174126 This _ -> Just Nothing
175127 These _ new -> Just $ Just new
176128 That new -> Just $ Just new
177129
178−applyMap :: Ord k => Map k v -> Map k (Maybe v) -> Map k v
179−applyMap olds diffs = flip Map.mapMaybe (align olds diffs) $ \case
180− This old -> Just old
181− These _ new -> new
182− That new -> new
130+diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)
131+diffMap olds news = flip Map.mapMaybe (align olds news) $ \case
132+ This _ -> Just Nothing
133+ These old new
134+ | old == new -> Nothing
135+ | otherwise -> Just $ Just new
136+ That new -> Just $ Just new
137+
138+applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
139+applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
140+ where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch
141+ maybeToEither = \case
142+ Nothing -> Left ()
143+ Just r -> Right r
144+
145+mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)
146+mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs)
147+ where (ls, rs) = Map.partition isLeft m
148+ fromLeft (Left l) = l
149+ fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible"
150+ fromRight (Right r) = r
151+ fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible"
152+
153+-- | Apply a map patch to a set
154+-- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m)
155+applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k
156+applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)
157+ where (insertions, deletions) = Map.partition isJust patch
183158
184159--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
185−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))
160+listWithKey :: forall t k v m a. (Ord k, DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
186161listWithKey vals mkChild = do
187162 postBuild <- getPostBuild
188− rec sentVals :: Dynamic t (Map k v) <- foldDyn (flip applyMap) Map.empty changeVals
163+ rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
189164 let changeVals :: Event t (Map k (Maybe v))
190165 changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost
191166 [ updated vals
192− , tag (current vals) postBuild
167+ , tag (current vals) postBuild --TODO: This should probably be added to the attachWith, not to the updated; if we were using diffMap instead of diffMapNoEq, I think it might not work
193168 ]
194169 listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do
195170 mkChild k =<< holdDyn v0 dv
196171
197172{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
198−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))
173+listWithKey' :: (Ord k, DomBuilder t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
199174listWithKey' = listWithKeyShallowDiff
200175
201176-- | 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.
202−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))
177+listWithKeyShallowDiff :: (Ord k, DomBuilder t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
203178listWithKeyShallowDiff initialVals valsChanged mkChild = do
204179 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
205− sentVals <- foldDyn (flip applyMap) (() <$ initialVals) $ fmap (fmap (fmap (\_ -> ()))) valsChanged
206− let relevantDiff diff _ = case diff of
180+ sentVals <- foldDyn applyMap Map.empty $ fmap (fmap void) valsChanged
181+ let relevantPatch patch _ = case patch of
207182 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
208183 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 ->
184+ listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
210185 mkChild k v $ Reflex.select childValChangedSelector $ Const2 k
211186
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.
213−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))
214−listHoldWithKey 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
267−
268187--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
269188-- | Create a dynamically-changing set of Event-valued widgets.
270189-- 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'.
271−listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
272−listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
190+listViewWithKey :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
191+listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
273192
274−listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
275−listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild
193+listViewWithKey' :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
194+listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
276195
277196-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
278−selectViewListWithKey :: forall t m k v a. (MonadWidget t m, Ord k)
197+selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
279198 => Dynamic t k -- ^ Current selection key
280199 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
281200 -> (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
@@ -283,465 +202,104 @@ selectViewListWithKey :: forall t m k v a. (MonadWidget t m, Ord k)
283202selectViewListWithKey selection vals mkChild = do
284203 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
285204 selectChild <- listWithKey vals $ \k v -> do
286− selected <- getDemuxed selectionDemux k
205+ let selected = demuxed selectionDemux k
287206 selectSelf <- mkChild k v selected
288207 return $ fmap ((,) k) selectSelf
289− liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
208+ return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
290209
291−selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k)
210+selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
292211 => Dynamic t k -- ^ Current selection key
293212 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
294213 -> (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
295214 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
296−selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewListWithKey selection vals mkChild
297−
298−--------------------------------------------------------------------------------
299−-- Basic DOM manipulation helpers
300−--------------------------------------------------------------------------------
301−
302−-- | s and e must both be children of the same node and s must precede e
303−deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
304−deleteBetweenExclusive 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
315−
316−-- | s and e must both be children of the same node and s must precede e
317−deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
318−deleteBetweenInclusive 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 ()
330−
331−nodeClear :: IsNode self => self -> IO ()
332−nodeClear 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
339−
340−--------------------------------------------------------------------------------
341−-- Adapters
342−--------------------------------------------------------------------------------
343−
344−wrapDomEvent :: (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)
345−wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue
346−
347−wrapDomEventMaybe :: (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)
348−wrapDomEventMaybe 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
358−
359−data 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
406−
407−data 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
454−
455−type 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
502−
503−onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
504−onEventName 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
551−
552−newtype EventResult en = EventResult { unEventResult :: EventResultType en }
553−
554−type 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 = ()
601−
602−wrapDomEventsMaybe :: (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))
603−wrapDomEventsMaybe 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
613−
614−getKeyEvent :: EventM e KeyboardEvent Int
615−getKeyEvent = 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
622−
623−getMouseEventCoords :: EventM e MouseEvent (Int, Int)
624−getMouseEventCoords = do
625− e <- event
626− bisequence (getClientX e, getClientY e)
627−
628−defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))
629−defaultDomEventHandler 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 ()
676−
677−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 Element (EventType en) (Maybe (EventResult en))) -> Element -> m (El t)
678−wrapElement eh e = do
679− es <- wrapDomEventsMaybe e $ eh e
680− return $ El e es
681−
682−{-# INLINABLE elStopPropagationNS #-}
683−elStopPropagationNS :: (MonadWidget t m, IsEvent (EventType en)) => Maybe String -> String -> EventName en -> m a -> m a
684−elStopPropagationNS 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
215+selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
688216
217+{-
689218{-# INLINABLE elWith #-}
690−elWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m a
219+elWith :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m a -> m a
691220elWith elementTag cfg child = do
692221 (_, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
693222 return result
694223
695224{-# INLINABLE elWith' #-}
696−elWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m (El t, a)
225+elWith' :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m a -> m (El t, a)
697226elWith' elementTag cfg child = do
698227 (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
699228 e' <- wrapElement defaultDomEventHandler e
700229 return (e', result)
701230
702231{-# INLINABLE emptyElWith #-}
703−emptyElWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m ()
232+emptyElWith :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m ()
704233emptyElWith elementTag cfg = do
705234 _ <- buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
706235 return ()
707236
708237{-# INLINABLE emptyElWith' #-}
709−emptyElWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m (El t)
238+emptyElWith' :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m (El t)
710239emptyElWith' elementTag cfg = do
711240 wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
241+-}
712242
713−{-# INLINABLE elDynAttrNS' #-}
714−elDynAttrNS' :: forall t m a. MonadWidget t m => Maybe String -> String -> Dynamic t (Map String String) -> m a -> m (El t, a)
715−elDynAttrNS' mns elementTag attrs = elWith' elementTag $
716− def & namespace .~ mns
717− & elConfig_attributes .~ attrs
718−
719−{-# INLINABLE elDynAttr' #-}
720−elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
721−elDynAttr' elementTag attrs = elWith' elementTag $ def & elConfig_attributes .~ attrs
243+{-# INLINABLE el #-}
244+el :: forall t m a. DomBuilder t m => Text -> m a -> m a
245+el elementTag child = snd <$> el' elementTag child
722246
723247{-# INLINABLE elAttr #-}
724−elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
725−elAttr elementTag attrs = elWith elementTag $ def & attributes .~ attrs
248+elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a
249+elAttr elementTag attrs child = snd <$> elAttr' elementTag attrs child
250+
251+{-# INLINABLE elClass #-}
252+elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a
253+elClass elementTag c child = snd <$> elClass' elementTag c child
254+
255+{-# INLINABLE elDynAttr #-}
256+elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
257+elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child
258+
259+{-# INLINABLE elDynClass #-}
260+elDynClass :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m a
261+elDynClass elementTag c child = snd <$> elDynClass' elementTag c child
726262
727263{-# INLINABLE el' #-}
728−el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
729−el' elementTag = elWith' elementTag def
264+el' :: forall t m a. DomBuilder t m => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
265+el' elementTag = element elementTag def
730266
731267{-# INLINABLE elAttr' #-}
732−elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
733−elAttr' elementTag attrs = elWith' elementTag $ def & attributes .~ attrs
268+elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
269+elAttr' elementTag attrs = element elementTag $ def
270+ & initialAttributes .~ Map.mapKeys (\k -> (Nothing, k)) attrs
734271
735−{-# INLINABLE elDynAttr #-}
736−elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
737−elDynAttr elementTag attrs = elWith elementTag $ def & elConfig_attributes .~ attrs
272+{-# INLINABLE elClass' #-}
273+elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
274+elClass' elementTag c = elAttr' elementTag ("class" =: c)
738275
739−{-# INLINABLE el #-}
740−el :: forall t m a. MonadWidget t m => String -> m a -> m a
741−el elementTag = elWith elementTag def
276+{-# INLINABLE elDynAttr' #-}
277+elDynAttr' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
278+elDynAttr' = elDynAttrNS' Nothing
742279
743−elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
744−elClass elementTag c = elWith elementTag $ def & attributes .~ "class" =: c
280+{-# INLINABLE elDynClass' #-}
281+elDynClass' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
282+elDynClass' elementTag c = elDynAttr' elementTag (fmap ("class" =:) c)
283+
284+{-# INLINABLE elDynAttrNS' #-}
285+elDynAttrNS' :: forall t m a. (DomBuilder t m, PostBuild t m) => Maybe Text -> Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
286+elDynAttrNS' mns elementTag attrs child = do
287+ modifyAttrs <- dynamicAttributesToModifyAttributes attrs
288+ let cfg = def
289+ & elementConfig_namespace .~ mns
290+ & modifyAttributes .~ modifyAttrs
291+ element elementTag cfg child
292+
293+dynamicAttributesToModifyAttributes :: PostBuild t m => Dynamic t (Map Text Text) -> m (Event t (Map AttributeName (Maybe Text)))
294+dynamicAttributesToModifyAttributes d = do
295+ postBuild <- getPostBuild
296+ let modificationsNeeded = flip pushAlways (align postBuild $ updated d) $ \case
297+ This () -> fmap (fmap Just) $ sample $ current d
298+ These () new -> return $ fmap Just new
299+ That new -> do
300+ old <- sample $ current d
301+ return $ diffMap old new
302+ return $ Map.fromList . fmap (\(k, v) -> ((Nothing, k), v)) . Map.toList <$> modificationsNeeded
745303
746304--------------------------------------------------------------------------------
747305-- Copied and pasted from Reflex.Widget.Class
@@ -749,98 +307,77 @@ elClass elementTag c = elWith elementTag $ def & attributes .~ "class" =: c
749307
750308-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
751309-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
752−list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
310+list :: (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
753311list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
754312
755313-- | Create a dynamically-changing set of widgets from a Dynamic list.
756−simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
757−simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs
314+simpleList :: (DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
315+simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs
758316
759−elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
317+{-
318+schedulePostBuild x = performEvent_ . (x <$) =<< getPostBuild
319+
320+elDynHtml' :: DomBuilder t m => Text -> Dynamic t Text -> m (El t)
760321elDynHtml' elementTag html = do
761− e <- buildEmptyElement elementTag (Map.empty :: Map String String)
322+ e <- buildEmptyElement elementTag (Map.empty :: Map Text Text)
762323 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
763− addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
324+ performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
764325 wrapElement defaultDomEventHandler e
765326
766−elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
327+elDynHtmlAttr' :: DomBuilder t m => Text -> Map Text Text -> Dynamic t Text -> m (El t)
767328elDynHtmlAttr' elementTag attrs html = do
768329 e <- buildEmptyElement elementTag attrs
769330 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
770− addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
331+ performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
771332 wrapElement defaultDomEventHandler e
333+-}
772334
773335data Link t
774336 = Link { _link_clicked :: Event t ()
775337 }
776338
777−class HasAttributes a where
778− type Attrs a :: *
779− attributes :: Lens' a (Attrs a)
780−
781−instance HasAttributes (ElConfig attrs) where
782− type Attrs (ElConfig attrs) = attrs
783− attributes = elConfig_attributes
784−
785−class HasNamespace a where
786− namespace :: Lens' a (Maybe String)
787−
788−instance HasNamespace (ElConfig attrs) where
789− namespace = elConfig_namespace
790−
791−class HasDomEvent t a where
792− domEvent :: EventName en -> a -> Event t (EventResultType en)
793−
794−instance Reflex t => HasDomEvent t (El t) where
795− domEvent en e = fmap unEventResult $ Reflex.select (_el_events e) (WrapArg en)
796−
797−linkClass :: MonadWidget t m => String -> String -> m (Link t)
339+linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
798340linkClass s c = do
799341 (l,_) <- elAttr' "a" ("class" =: c) $ text s
800342 return $ Link $ domEvent Click l
801343
802−link :: MonadWidget t m => String -> m (Link t)
344+link :: DomBuilder t m => Text -> m (Link t)
803345link s = linkClass s ""
804346
805−button :: MonadWidget t m => String -> m (Event t ())
806−button s = do
807− (e, _) <- elAttr' "button" (Map.singleton "type" "button") $ text s
808− return $ domEvent Click e
809−
810347newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
811348
812−workflow :: forall t m a. MonadWidget t m => Workflow t m a -> m (Dynamic t a)
349+workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
813350workflow w0 = do
814− rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ fmap snd $ current eResult
815− mapDyn fst eResult
351+ rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
352+ return $ fmap fst eResult
816353
817−workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
354+workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
818355workflowView w0 = do
819− rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
820− eReplace <- liftM switch $ hold never $ fmap snd eResult
356+ rec eResult <- dyn . fmap unWorkflow =<< holdDyn w0 eReplace
357+ eReplace <- fmap switch $ hold never $ fmap snd eResult
821358 return $ fmap fst eResult
822359
823−mapWorkflow :: (MonadWidget t m) => (a -> b) -> Workflow t m a -> Workflow t m b
824−mapWorkflow f (Workflow x) = Workflow (fmap (\(v,e) -> (f v, fmap (mapWorkflow f) e)) x)
360+mapWorkflow :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b
361+mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
825362
826−divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
363+divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
827364divClass = elClass "div"
828365
829−dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
366+dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a
830367dtdd h w = do
831368 el "dt" $ text h
832− el "dd" $ w
369+ el "dd" w
833370
834−blank :: forall t m. MonadWidget t m => m ()
371+blank :: forall m. Monad m => m ()
835372blank = return ()
836373
837374-- | A widget to display a table with static columns and dynamic rows.
838−tableDynAttr :: 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)
375+tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)
376+ => Text -- ^ Class applied to <table> element
377+ -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
841378 -> 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)
379+ -> (k -> m (Dynamic t (Map Text Text))) -- ^ Function to compute <tr> element attributes from row key
380+ -> m (Dynamic t (Map k (Element EventResult (DomBuilderSpace m) t, [v]))) -- ^ Map from row key to (El, list of widget return values)
844381tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
845382 elAttr "table" (Map.singleton "class" klass) $ do
846383 el "thead" $ el "tr" $ do
@@ -854,54 +391,31 @@ tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zo
854391-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
855392-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
856393-- the corresponding child and hides all others.
857−tabDisplay :: 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)
394+tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)
395+ => Text -- ^ Class applied to <ul> element
396+ -> Text -- ^ Class applied to currently active <li> element
397+ -> Map k (Text, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)
861398 -> m ()
862399tabDisplay 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
400+ let t0 = listToMaybe $ Map.keys tabItems
401+ rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do
402+ tabClicksList :: [Event t k] <- Map.elems <$> imapM (\k (s,_) -> headerBarLink s k $ demuxed currentTab (Just k)) tabItems
866403 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)
404+ fmap demux $ holdDyn t0 $ fmap Just eTabClicks
405+ el "div" $ do
406+ iforM_ tabItems $ \k (_, w) -> do
407+ let isSelected = demuxed currentTab $ Just k
408+ attrs = ffor isSelected $ \s -> if s then Map.empty else Map.singleton "style" "display:none;"
409+ elDynAttr "div" attrs w
875410 return ()
876411 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
412+ headerBarLink :: Text -> k -> Dynamic t Bool -> m (Event t k)
413+ headerBarLink x k isSelected = do
414+ let attrs = fmap (\b -> if b then Map.singleton "class" activeClass else Map.empty) isSelected
415+ elDynAttr "li" attrs $ do
881416 a <- link x
882417 return $ fmap (const k) (_link_clicked a)
883418
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.
885−unsafePlaceElement :: MonadWidget t m => Element -> m (El t)
886−unsafePlaceElement e = do
887− p <- askParent
888− _ <- appendChild p $ Just e
889− wrapElement defaultDomEventHandler e
890−
891−deriveGEq ''EventName
892−deriveGCompare ''EventName
893−
894−--------------------------------------------------------------------------------
895−-- Deprecated functions
896−
897−{-# DEPRECATED _el_clicked "Use `domEvent Click` instead" #-}
898−_el_clicked :: Reflex t => El t -> Event t ()
899−_el_clicked = domEvent Click
900−
901−{-# DEPRECATED _el_keypress "Use `domEvent Keypress` instead" #-}
902−_el_keypress :: Reflex t => El t -> Event t Int
903−_el_keypress = domEvent Keypress
904−
905−{-# DEPRECATED _el_scrolled "Use `domEvent Scroll` instead" #-}
906−_el_scrolled :: Reflex t => El t -> Event t Int
907−_el_scrolled = domEvent Scroll
419+class HasAttributes a where
420+ type Attrs a :: *
421+ attributes :: Lens' a (Attrs a)