@@ -1,137 +1,102 @@
1−{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes, TemplateHaskell #-}
1+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes, TemplateHaskell #-}
22
33module Reflex.Dom.Widget.Basic where
44
55import Reflex.Dom.Class
66import Reflex.Dom.Internal.Foreign ()
7+import Reflex.Dom.PostBuild.Class
8+import Reflex.Dom.Builder.Class
79
810import Prelude hiding (mapM, mapM_, sequence, sequence_)
911import Reflex
10−import Reflex.Host.Class
1112import Data.Functor.Misc
1213import Data.Map (Map)
1314import qualified Data.Map as Map
1415import Data.Set (Set)
1516import qualified Data.Set as Set
16−import Data.Dependent.Sum (DSum (..))
1717import Data.Foldable
1818import Data.Traversable
19−import Control.Monad.Trans
2019import 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
3020import Control.Lens hiding (element, children)
3121import Data.These
3222import Data.Align
3323import Data.Maybe
34−import Data.GADT.Compare.TH
35−import Data.Bitraversable
36−import GHCJS.DOM.MouseEvent
37−import Data.IORef
3824import Data.Default
25+import Data.Either
26+import Data.Semigroup
27+import Data.Text (Text)
28+import qualified Data.Text as T
29+
30+widgetHoldInternal :: DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
31+widgetHoldInternal child0 child' = do
32+ childResult0 <- deletable (void child') child0
33+ childResult' <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (deletable (void child')) child'
34+ return (childResult0, _placeholder_insertedAbove childResult')
35+
36+-- | 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.
37+-- 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.
38+-- No empty pieces will be included in the output.
39+
40+--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
41+partitionMapBySetLT :: forall k v. Ord k => Set k -> Map k v -> Map (Either k ()) (Map k v)
42+partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0
43+ where go :: [k] -> Map k v -> [(Either k (), Map k v)]
44+ go [] m = if Map.null m
45+ then []
46+ else [(Right (), m)]
47+ go (h:t) m = let (lt, eq, gt) = Map.splitLookup h m
48+ geq = maybe id (Map.insert h) eq gt
49+ in if Map.null lt
50+ then go t geq
51+ else (Left h, lt) : go t geq
52+
53+newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }
54+
55+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))
56+listHoldWithKey initialChildren modifyChildren buildChild = do
57+ let deleteChildSelector = fanMap $ fmap void modifyChildren
58+ liveChildren :: Dynamic t (Set k) <- foldDyn applyMapKeysSet (Map.keysSet initialChildren) modifyChildren
59+ let placeChildSelector = fanMap $ attachWith partitionMapBySetLT (current liveChildren) $ fmap (Map.mapMaybe id) modifyChildren
60+ buildAugmentedChild :: k -> v -> m (ChildResult t k a)
61+ buildAugmentedChild k v = do
62+ let delete = select deleteChildSelector $ Const2 k
63+ myCfg = def
64+ & insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Left k)
65+ & deleteSelf .~ delete
66+ (me, result) <- fragment myCfg $ buildChild k v
67+ return $ ChildResult (result, (fmap (fmap Just) $ _fragment_insertedAbove me) <> (Map.singleton k Nothing <$ _fragment_deleted me)) --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
68+ rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild
69+ augmentedResults <- foldDyn applyMap initialAugmentedResults $ newInsertedBelow <> newInsertedAbove
70+ let newInsertedAbove = switch $ fmap (mconcat . reverse . fmap (snd . unChildResult) . Map.elems) $ current augmentedResults
71+ belowAll <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Right ())
72+ let newInsertedBelow = fmap (fmap Just) $ _placeholder_insertedAbove belowAll
73+ mapDyn (fmap (fst . unChildResult)) augmentedResults
74+
75+text :: DomBuilder t m => Text -> m ()
76+text t = void $ textNode $ def & textNodeConfig_contents .~ t
77+
78+dynText :: (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
79+dynText t = do
80+ postBuild <- getPostBuild
81+ _ <- widgetHoldInternal (return ()) $ text <$> leftmost
82+ [ updated t
83+ , tag (current t) postBuild
84+ ]
85+ return ()
86+
87+display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
88+display = dynText <=< mapDyn (T.pack . show)
3989
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
90+button :: DomBuilder t m => Text -> m (Event t ())
91+button t = do
92+ (e, _) <- element "button" def $ text t
93+ return $ domEvent Click e
12994
13095--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
13196-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
13297-- The returned Event of widget results occurs when the Dynamic does.
13398-- 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)
99+dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
135100dyn child = do
136101 postBuild <- getPostBuild
137102 let newChild = leftmost [updated child, tag (current child) postBuild]
@@ -140,158 +105,93 @@ dyn child = do
140105-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
141106-- The returned Dynamic of widget results occurs when the Event does.
142107-- 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)
108+widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
144109widgetHold child0 newChild = do
145110 (result0, newResult) <- widgetHoldInternal child0 newChild
146111 holdDyn result0 newResult
147112
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− childOutput <- holdDyn (Map.singleton () childVoidAction0) $ fmap (Map.singleton () . snd) newChildBuilt
158− tellWidgetOutput childOutput
159− doc <- askDocument
160− runWidget <- getRunWidget
161− let build c = do
162− Just df <- createDocumentFragment doc
163− (result, postBuild, voidActions) <- runWidget df c
164− scheduleFollowup newChildBuiltTriggerRef (result, voidActions)
165− postBuild
166− mp' <- getParentNode endPlaceholder
167− forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder)
168− return ()
169− addVoidAction $ ffor newChild $ \c -> do
170− Just df <- createDocumentFragment doc
171− (result, postBuild, voidActions) <- runWidget df c
172− runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)
173− postBuild
174− liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
175− mp' <- getParentNode endPlaceholder
176− forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder)
177− return ()
178− return (result0, fmap fst newChildBuilt)
179−
180113diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
181114diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
182115 This _ -> Just Nothing
183116 These _ new -> Just $ Just new
184117 That new -> Just $ Just new
185118
186−applyMap :: Ord k => Map k v -> Map k (Maybe v) -> Map k v
187−applyMap olds diffs = flip Map.mapMaybe (align olds diffs) $ \case
188− This old -> Just old
189− These _ new -> new
190− That new -> new
119+diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)
120+diffMap olds news = flip Map.mapMaybe (align olds news) $ \case
121+ This _ -> Just Nothing
122+ These old new
123+ | old == new -> Nothing
124+ | otherwise -> Just $ Just new
125+ That new -> Just $ Just new
126+
127+applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
128+applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
129+ where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch
130+ maybeToEither = \case
131+ Nothing -> Left ()
132+ Just r -> Right r
133+
134+mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)
135+mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs)
136+ where (ls, rs) = Map.partition isLeft m
137+ fromLeft (Left l) = l
138+ fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible"
139+ fromRight (Right r) = r
140+ fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible"
141+
142+-- | Apply a map patch to a set
143+-- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m)
144+applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k
145+applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)
146+ where (insertions, deletions) = Map.partition isJust patch
191147
192148--HACK: A listWithKey that is inefficient but works around a subtle buggy interaction with DynamicWriterT
193−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))
149+listWithKey :: forall t k v m a. (PostBuild t m, DomBuilder t m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
194150listWithKey eltsMapD body = do
195151 pb <- getPostBuild
196152 widgetHold (return Map.empty) $ ffor (leftmost [ tagDyn eltsMapD pb, updated eltsMapD ]) $ imapM $ \k v -> body k (constDyn v)
197153
198154{-
199155--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
200−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))
156+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))
201157listWithKey vals mkChild = do
202158 postBuild <- getPostBuild
203− rec sentVals :: Dynamic t (Map k v) <- foldDyn (flip applyMap) Map.empty changeVals
159+ rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
204160 let changeVals :: Event t (Map k (Maybe v))
205161 changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost
206162 [ updated vals
207− , tag (current vals) postBuild
163+ , 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
208164 ]
209165 listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do
210166 mkChild k =<< holdDyn v0 dv
211167-}
212168
213169{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
214−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))
170+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))
215171listWithKey' = listWithKeyShallowDiff
216172
217173-- | 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.
218−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))
174+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))
219175listWithKeyShallowDiff initialVals valsChanged mkChild = do
220176 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
221− sentVals <- foldDyn (flip applyMap) Map.empty $ fmap (fmap (fmap (\_ -> ()))) valsChanged
222− let relevantDiff diff _ = case diff of
177+ sentVals <- foldDyn applyMap Map.empty $ fmap (fmap (fmap (\_ -> ()))) valsChanged
178+ let relevantPatch patch _ = case patch of
223179 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
224180 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
225− listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantDiff)) (current sentVals) valsChanged) $ \k v ->
181+ listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
226182 mkChild k v $ Reflex.select childValChangedSelector $ Const2 k
227183
228−-- | 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.
229−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))
230−listHoldWithKey initialVals valsChanged mkChild = do
231− doc <- askDocument
232− endPlaceholder <- text' ""
233− (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
234− runWidget <- getRunWidget
235− let buildChild df k v = runWidget df $ wrapChild k v
236− wrapChild k v = do
237− childStart <- text' ""
238− result <- mkChild k v
239− childEnd <- text' ""
240− return (result, (childStart, childEnd))
241− Just dfOrig <- createDocumentFragment doc
242− 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
243− stateRef <- liftIO $ newIORef initialState
244− children <- holdDyn initialState newChildren
245− tellWidgetOutput =<< mapDyn (fmap snd) children
246− mpOrig <- liftIO $ getParentNode endPlaceholder
247− forM_ mpOrig $ \pOrig -> liftIO $ insertBefore pOrig (Just dfOrig) (Just endPlaceholder)
248− addVoidAction $ flip fmap valsChanged $ \newVals -> do
249− curState <- liftIO $ readIORef stateRef
250− --TODO: Should we remove the parent from the DOM first to avoid reflows?
251− (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
252− These ((_, (start, end)), _) Nothing -> do -- Deleting child
253− liftIO $ deleteBetweenInclusive start end
254− return Nothing
255− These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child
256− liftIO $ deleteBetweenExclusive start end
257− Just df <- createDocumentFragment doc
258− (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
259− let s = (childResult, childVoidAction)
260− modify (>>childPostBuild)
261− mp <- getParentNode end
262− forM_ mp $ \p -> insertBefore p (Just df) (Just end)
263− return $ Just s
264− That Nothing -> return Nothing -- Deleting non-existent child
265− That (Just v) -> do -- Creating new child
266− Just df <- createDocumentFragment doc
267− (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
268− let s = (childResult, childVoidAction)
269− modify (>>childPostBuild)
270− let placeholder = case Map.lookupGT k curState of
271− Nothing -> endPlaceholder
272− Just (_, ((_, (start, _)), _)) -> start
273− mp <- getParentNode placeholder
274− forM_ mp $ \p -> insertBefore p (Just df) (Just placeholder)
275− return $ Just s
276− This state -> do -- No change
277− return $ Just state
278− liftIO $ writeIORef stateRef newState
279− runFrameWithTriggerRef newChildrenTriggerRef newState
280− postBuild
281− mapDyn (fmap (fst . fst)) children
282−
283184--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
284185-- | Create a dynamically-changing set of Event-valued widgets.
285186-- 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'.
286−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))
187+listViewWithKey :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
287188listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
288189
289−
290−listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
190+listViewWithKey' :: (DomBuilder t m, PostBuild t m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
291191listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild
292192
293193-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
294−selectViewListWithKey :: forall t m k v a. (MonadWidget t m, Ord k)
194+selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m)
295195 => Dynamic t k -- ^ Current selection key
296196 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
297197 -> (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
@@ -304,460 +204,86 @@ selectViewListWithKey selection vals mkChild = do
304204 return $ fmap ((,) k) selectSelf
305205 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
306206
307−selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k)
207+selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m)
308208 => Dynamic t k -- ^ Current selection key
309209 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
310210 -> (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
311211 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
312212selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewListWithKey selection vals mkChild
313213
314−--------------------------------------------------------------------------------
315−-- Basic DOM manipulation helpers
316−--------------------------------------------------------------------------------
317−
318−-- | s and e must both be children of the same node and s must precede e
319−deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
320−deleteBetweenExclusive s e = do
321− 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
322− case mCurrentParent of
323− Nothing -> return () --TODO: Is this the right behavior?
324− Just currentParent -> do
325− let go = do
326− Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
327− when (toNode s /= toNode x) $ do
328− _ <- removeChild currentParent $ Just x
329− go
330− go
331−
332−-- | s and e must both be children of the same node and s must precede e
333−deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
334−deleteBetweenInclusive s e = do
335− 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
336− case mCurrentParent of
337− Nothing -> return () --TODO: Is this the right behavior?
338− Just currentParent -> do
339− let go = do
340− Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
341− _ <- removeChild currentParent $ Just x
342− when (toNode s /= toNode x) go
343− go
344− _ <- removeChild currentParent $ Just e
345− return ()
346−
347−nodeClear :: IsNode self => self -> IO ()
348−nodeClear n = do
349− mfc <- getFirstChild n
350− case mfc of
351− Nothing -> return ()
352− Just fc -> do
353− _ <- removeChild n $ Just fc
354− nodeClear n
355−
356−--------------------------------------------------------------------------------
357−-- Adapters
358−--------------------------------------------------------------------------------
359−
360−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)
361−wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue
362−
363−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)
364−wrapDomEventMaybe element elementOnevent getValue = do
365− postGui <- askPostGui
366− runWithActions <- askRunWithActions
367− e <- newEventWithTrigger $ \et -> do
368− unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
369− mv <- {-# SCC "d" #-} getValue
370− forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]
371− return $ liftIO $ do
372− {-# SCC "e" #-} unsubscribe
373− return $! {-# SCC "f" #-} e
374−
375−data EventTag
376− = AbortTag
377− | BlurTag
378− | ChangeTag
379− | ClickTag
380− | ContextmenuTag
381− | DblclickTag
382− | DragTag
383− | DragendTag
384− | DragenterTag
385− | DragleaveTag
386− | DragoverTag
387− | DragstartTag
388− | DropTag
389− | ErrorTag
390− | FocusTag
391− | InputTag
392− | InvalidTag
393− | KeydownTag
394− | KeypressTag
395− | KeyupTag
396− | LoadTag
397− | MousedownTag
398− | MouseenterTag
399− | MouseleaveTag
400− | MousemoveTag
401− | MouseoutTag
402− | MouseoverTag
403− | MouseupTag
404− | MousewheelTag
405− | ScrollTag
406− | SelectTag
407− | SubmitTag
408− | WheelTag
409− | BeforecutTag
410− | CutTag
411− | BeforecopyTag
412− | CopyTag
413− | BeforepasteTag
414− | PasteTag
415− | ResetTag
416− | SearchTag
417− | SelectstartTag
418− | TouchstartTag
419− | TouchmoveTag
420− | TouchendTag
421− | TouchcancelTag
422−
423−data EventName :: EventTag -> * where
424− Abort :: EventName 'AbortTag
425− Blur :: EventName 'BlurTag
426− Change :: EventName 'ChangeTag
427− Click :: EventName 'ClickTag
428− Contextmenu :: EventName 'ContextmenuTag
429− Dblclick :: EventName 'DblclickTag
430− Drag :: EventName 'DragTag
431− Dragend :: EventName 'DragendTag
432− Dragenter :: EventName 'DragenterTag
433− Dragleave :: EventName 'DragleaveTag
434− Dragover :: EventName 'DragoverTag
435− Dragstart :: EventName 'DragstartTag
436− Drop :: EventName 'DropTag
437− Error :: EventName 'ErrorTag
438− Focus :: EventName 'FocusTag
439− Input :: EventName 'InputTag
440− Invalid :: EventName 'InvalidTag
441− Keydown :: EventName 'KeydownTag
442− Keypress :: EventName 'KeypressTag
443− Keyup :: EventName 'KeyupTag
444− Load :: EventName 'LoadTag
445− Mousedown :: EventName 'MousedownTag
446− Mouseenter :: EventName 'MouseenterTag
447− Mouseleave :: EventName 'MouseleaveTag
448− Mousemove :: EventName 'MousemoveTag
449− Mouseout :: EventName 'MouseoutTag
450− Mouseover :: EventName 'MouseoverTag
451− Mouseup :: EventName 'MouseupTag
452− Mousewheel :: EventName 'MousewheelTag
453− Scroll :: EventName 'ScrollTag
454− Select :: EventName 'SelectTag
455− Submit :: EventName 'SubmitTag
456− Wheel :: EventName 'WheelTag
457− Beforecut :: EventName 'BeforecutTag
458− Cut :: EventName 'CutTag
459− Beforecopy :: EventName 'BeforecopyTag
460− Copy :: EventName 'CopyTag
461− Beforepaste :: EventName 'BeforepasteTag
462− Paste :: EventName 'PasteTag
463− Reset :: EventName 'ResetTag
464− Search :: EventName 'SearchTag
465− Selectstart :: EventName 'SelectstartTag
466− Touchstart :: EventName 'TouchstartTag
467− Touchmove :: EventName 'TouchmoveTag
468− Touchend :: EventName 'TouchendTag
469− Touchcancel :: EventName 'TouchcancelTag
470−
471−type family EventType en where
472− EventType 'AbortTag = UIEvent
473− EventType 'BlurTag = FocusEvent
474− EventType 'ChangeTag = DOM.Event
475− EventType 'ClickTag = MouseEvent
476− EventType 'ContextmenuTag = MouseEvent
477− EventType 'DblclickTag = MouseEvent
478− EventType 'DragTag = MouseEvent
479− EventType 'DragendTag = MouseEvent
480− EventType 'DragenterTag = MouseEvent
481− EventType 'DragleaveTag = MouseEvent
482− EventType 'DragoverTag = MouseEvent
483− EventType 'DragstartTag = MouseEvent
484− EventType 'DropTag = MouseEvent
485− EventType 'ErrorTag = UIEvent
486− EventType 'FocusTag = FocusEvent
487− EventType 'InputTag = DOM.Event
488− EventType 'InvalidTag = DOM.Event
489− EventType 'KeydownTag = KeyboardEvent
490− EventType 'KeypressTag = KeyboardEvent
491− EventType 'KeyupTag = KeyboardEvent
492− EventType 'LoadTag = UIEvent
493− EventType 'MousedownTag = MouseEvent
494− EventType 'MouseenterTag = MouseEvent
495− EventType 'MouseleaveTag = MouseEvent
496− EventType 'MousemoveTag = MouseEvent
497− EventType 'MouseoutTag = MouseEvent
498− EventType 'MouseoverTag = MouseEvent
499− EventType 'MouseupTag = MouseEvent
500− EventType 'MousewheelTag = MouseEvent
501− EventType 'ScrollTag = UIEvent
502− EventType 'SelectTag = UIEvent
503− EventType 'SubmitTag = DOM.Event
504− EventType 'WheelTag = WheelEvent
505− EventType 'BeforecutTag = DOM.Event
506− EventType 'CutTag = DOM.Event
507− EventType 'BeforecopyTag = DOM.Event
508− EventType 'CopyTag = DOM.Event
509− EventType 'BeforepasteTag = DOM.Event
510− EventType 'PasteTag = DOM.Event
511− EventType 'ResetTag = DOM.Event
512− EventType 'SearchTag = DOM.Event
513− EventType 'SelectstartTag = DOM.Event
514− EventType 'TouchstartTag = TouchEvent
515− EventType 'TouchmoveTag = TouchEvent
516− EventType 'TouchendTag = TouchEvent
517− EventType 'TouchcancelTag = TouchEvent
518−
519−onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
520−onEventName en e = case en of
521− Abort -> on e E.abort
522− Blur -> on e E.blurEvent
523− Change -> on e E.change
524− Click -> on e E.click
525− Contextmenu -> on e E.contextMenu
526− Dblclick -> on e E.dblClick
527− Drag -> on e E.drag
528− Dragend -> on e E.dragEnd
529− Dragenter -> on e E.dragEnter
530− Dragleave -> on e E.dragLeave
531− Dragover -> on e E.dragOver
532− Dragstart -> on e E.dragStart
533− Drop -> on e E.drop
534− Error -> on e E.error
535− Focus -> on e E.focusEvent
536− Input -> on e E.input
537− Invalid -> on e E.invalid
538− Keydown -> on e E.keyDown
539− Keypress -> on e E.keyPress
540− Keyup -> on e E.keyUp
541− Load -> on e E.load
542− Mousedown -> on e E.mouseDown
543− Mouseenter -> on e E.mouseEnter
544− Mouseleave -> on e E.mouseLeave
545− Mousemove -> on e E.mouseMove
546− Mouseout -> on e E.mouseOut
547− Mouseover -> on e E.mouseOver
548− Mouseup -> on e E.mouseUp
549− Mousewheel -> on e E.mouseWheel
550− Scroll -> on e E.scroll
551− Select -> on e E.select
552− Submit -> on e E.submit
553− Wheel -> on e E.wheel
554− Beforecut -> on e E.beforeCut
555− Cut -> on e E.cut
556− Beforecopy -> on e E.beforeCopy
557− Copy -> on e E.copy
558− Beforepaste -> on e E.beforePaste
559− Paste -> on e E.paste
560− Reset -> on e E.reset
561− Search -> on e E.search
562− Selectstart -> on e E.selectStart
563− Touchstart -> on e E.touchStart
564− Touchmove -> on e E.touchMove
565− Touchend -> on e E.touchEnd
566− Touchcancel -> on e E.touchCancel
567−
568−newtype EventResult en = EventResult { unEventResult :: EventResultType en }
569−
570−type family EventResultType (en :: EventTag) :: * where
571− EventResultType 'ClickTag = ()
572− EventResultType 'DblclickTag = ()
573− EventResultType 'KeypressTag = Int
574− EventResultType 'KeydownTag = Int
575− EventResultType 'KeyupTag = Int
576− EventResultType 'ScrollTag = Int
577− EventResultType 'MousemoveTag = (Int, Int)
578− EventResultType 'MousedownTag = (Int, Int)
579− EventResultType 'MouseupTag = (Int, Int)
580− EventResultType 'MouseenterTag = ()
581− EventResultType 'MouseleaveTag = ()
582− EventResultType 'FocusTag = ()
583− EventResultType 'BlurTag = ()
584− EventResultType 'ChangeTag = ()
585− EventResultType 'DragTag = ()
586− EventResultType 'DragendTag = ()
587− EventResultType 'DragenterTag = ()
588− EventResultType 'DragleaveTag = ()
589− EventResultType 'DragoverTag = ()
590− EventResultType 'DragstartTag = ()
591− EventResultType 'DropTag = ()
592− EventResultType 'AbortTag = ()
593− EventResultType 'ContextmenuTag = ()
594− EventResultType 'ErrorTag = ()
595− EventResultType 'InputTag = ()
596− EventResultType 'InvalidTag = ()
597− EventResultType 'LoadTag = ()
598− EventResultType 'MouseoutTag = ()
599− EventResultType 'MouseoverTag = ()
600− EventResultType 'SelectTag = ()
601− EventResultType 'SubmitTag = ()
602− EventResultType 'BeforecutTag = ()
603− EventResultType 'CutTag = ()
604− EventResultType 'BeforecopyTag = ()
605− EventResultType 'CopyTag = ()
606− EventResultType 'BeforepasteTag = ()
607− EventResultType 'PasteTag = ()
608− EventResultType 'ResetTag = ()
609− EventResultType 'SearchTag = ()
610− EventResultType 'SelectstartTag = ()
611− EventResultType 'TouchstartTag = ()
612− EventResultType 'TouchmoveTag = ()
613− EventResultType 'TouchendTag = ()
614− EventResultType 'TouchcancelTag = ()
615− EventResultType 'MousewheelTag = ()
616− EventResultType 'WheelTag = ()
617−
618−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))
619−wrapDomEventsMaybe element handlers = do
620− postGui <- askPostGui
621− runWithActions <- askRunWithActions
622− e <- newFanEventWithTrigger $ \(WrapArg en) et -> do
623− unsubscribe <- onEventName en element $ do
624− mv <- handlers en
625− forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]
626− return $ liftIO $ do
627− unsubscribe
628− return $! e
629−
630−getKeyEvent :: EventM e KeyboardEvent Int
631−getKeyEvent = do
632− e <- event
633− which <- getWhich e
634− if which /= 0 then return which else do
635− charCode <- getCharCode e
636− if charCode /= 0 then return charCode else
637− getKeyCode e
638−
639−getMouseEventCoords :: EventM e MouseEvent (Int, Int)
640−getMouseEventCoords = do
641− e <- event
642− bisequence (getX e, getY e)
643−
644−defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))
645−defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
646− Click -> return ()
647− Dblclick -> return ()
648− Keypress -> getKeyEvent
649− Scroll -> getScrollTop e
650− Keydown -> getKeyEvent
651− Keyup -> getKeyEvent
652− Mousemove -> getMouseEventCoords
653− Mouseup -> getMouseEventCoords
654− Mousedown -> getMouseEventCoords
655− Mouseenter -> return ()
656− Mouseleave -> return ()
657− Focus -> return ()
658− Blur -> return ()
659− Change -> return ()
660− Drag -> return ()
661− Dragend -> return ()
662− Dragenter -> return ()
663− Dragleave -> return ()
664− Dragover -> return ()
665− Dragstart -> return ()
666− Drop -> return ()
667− Abort -> return ()
668− Contextmenu -> return ()
669− Error -> return ()
670− Input -> return ()
671− Invalid -> return ()
672− Load -> return ()
673− Mouseout -> return ()
674− Mouseover -> return ()
675− Select -> return ()
676− Submit -> return ()
677− Beforecut -> return ()
678− Cut -> return ()
679− Beforecopy -> return ()
680− Copy -> return ()
681− Beforepaste -> return ()
682− Paste -> return ()
683− Reset -> return ()
684− Search -> return ()
685− Selectstart -> return ()
686− Touchstart -> return ()
687− Touchmove -> return ()
688− Touchend -> return ()
689− Touchcancel -> return ()
690− Mousewheel -> return ()
691− Wheel -> return ()
692−
693−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)
694−wrapElement eh e = do
695− es <- wrapDomEventsMaybe e $ eh e
696− return $ El e es
697−
698−{-# INLINABLE elStopPropagationNS #-}
699−elStopPropagationNS :: (MonadWidget t m, IsEvent (EventType en)) => Maybe String -> String -> EventName en -> m a -> m a
700−elStopPropagationNS mns elementTag evt child = do
701− (e, result) <- buildElementNS mns elementTag (Map.empty :: Map String String) child
702− _ <- liftIO $ onEventName evt e stopPropagation
703− return result
704−
214+{-
705215{-# INLINABLE elWith #-}
706−elWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m a
216+elWith :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m a -> m a
707217elWith elementTag cfg child = do
708218 (_, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
709219 return result
710220
711221{-# INLINABLE elWith' #-}
712−elWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m (El t, a)
222+elWith' :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m a -> m (El t, a)
713223elWith' elementTag cfg child = do
714224 (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
715225 e' <- wrapElement defaultDomEventHandler e
716226 return (e', result)
717227
718228{-# INLINABLE emptyElWith #-}
719−emptyElWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m ()
229+emptyElWith :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m ()
720230emptyElWith elementTag cfg = do
721231 _ <- buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
722232 return ()
723233
724234{-# INLINABLE emptyElWith' #-}
725−emptyElWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m (El t)
235+emptyElWith' :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m (El t)
726236emptyElWith' elementTag cfg = do
727237 wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
238+-}
239+
240+dynamicAttributesToModifyAttributes :: PostBuild t m => Dynamic t (Map Text Text) -> m (Event t (Map AttributeName (Maybe Text)))
241+dynamicAttributesToModifyAttributes d = do
242+ postBuild <- getPostBuild
243+ let modificationsNeeded = flip pushAlways (align postBuild $ updated d) $ \case
244+ This () -> fmap (fmap Just) $ sample $ current d
245+ These () new -> return $ fmap Just new
246+ That new -> do
247+ old <- sample $ current d
248+ return $ diffMap old new
249+ return $ Map.fromList . fmap (\(k, v) -> ((Nothing, k), v)) . Map.toList <$> modificationsNeeded
728250
729251{-# INLINABLE elDynAttrNS' #-}
730−elDynAttrNS' :: forall t m a. MonadWidget t m => Maybe String -> String -> Dynamic t (Map String String) -> m a -> m (El t, a)
731−elDynAttrNS' mns elementTag attrs = elWith' elementTag $
732− def & namespace .~ mns
733− & elConfig_attributes .~ attrs
252+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)
253+elDynAttrNS' mns elementTag attrs child = do
254+ modifyAttrs <- dynamicAttributesToModifyAttributes attrs
255+ let cfg = def
256+ & elementConfig_namespace .~ mns
257+ & modifyAttributes .~ modifyAttrs
258+ element elementTag cfg child
734259
735260{-# INLINABLE elDynAttr' #-}
736−elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
737−elDynAttr' elementTag attrs = elWith' elementTag $ def & elConfig_attributes .~ attrs
261+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)
262+elDynAttr' = elDynAttrNS' Nothing
738263
739264{-# INLINABLE elAttr #-}
740−elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
741−elAttr elementTag attrs = elWith elementTag $ def & attributes .~ attrs
265+elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a
266+elAttr elementTag attrs child = snd <$> elAttr' elementTag attrs child
742267
743268{-# INLINABLE el' #-}
744−el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
745−el' elementTag = elWith' elementTag def
269+el' :: forall t m a. DomBuilder t m => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
270+el' elementTag = element elementTag def
746271
747272{-# INLINABLE elAttr' #-}
748−elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
749−elAttr' elementTag attrs = elWith' elementTag $ def & attributes .~ attrs
273+elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
274+elAttr' elementTag attrs = element elementTag $ def
275+ & initialAttributes .~ (Map.fromList $ fmap (\(k, v) -> ((Nothing, k), v)) $ Map.toList $ attrs)
750276
751277{-# INLINABLE elDynAttr #-}
752−elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
753−elDynAttr elementTag attrs = elWith elementTag $ def & elConfig_attributes .~ attrs
278+elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
279+elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child
754280
755281{-# INLINABLE el #-}
756−el :: forall t m a. MonadWidget t m => String -> m a -> m a
757−el elementTag = elWith elementTag def
282+el :: forall t m a. DomBuilder t m => Text -> m a -> m a
283+el elementTag child = snd <$> el' elementTag child
758284
759−elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
760−elClass elementTag c = elWith elementTag $ def & attributes .~ "class" =: c
285+elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a
286+elClass elementTag c child = fmap snd $ element elementTag (def & initialAttributes .~ (Nothing, "class") =: c) child
761287
762288--------------------------------------------------------------------------------
763289-- Copied and pasted from Reflex.Widget.Class
@@ -765,98 +291,77 @@ elClass elementTag c = elWith elementTag $ def & attributes .~ "class" =: c
765291
766292-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
767293-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
768−list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
294+list :: (DomBuilder t m, MonadHold t m, PostBuild t m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
769295list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
770296
771297-- | Create a dynamically-changing set of widgets from a Dynamic list.
772−simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
298+simpleList :: (DomBuilder t m, MonadHold t m, PostBuild t m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
773299simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs
774300
775−elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
301+{-
302+schedulePostBuild x = performEvent_ . (x <$) =<< getPostBuild
303+
304+elDynHtml' :: DomBuilder t m => Text -> Dynamic t Text -> m (El t)
776305elDynHtml' elementTag html = do
777− e <- buildEmptyElement elementTag (Map.empty :: Map String String)
306+ e <- buildEmptyElement elementTag (Map.empty :: Map Text Text)
778307 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
779− addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
308+ performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
780309 wrapElement defaultDomEventHandler e
781310
782−elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
311+elDynHtmlAttr' :: DomBuilder t m => Text -> Map Text Text -> Dynamic t Text -> m (El t)
783312elDynHtmlAttr' elementTag attrs html = do
784313 e <- buildEmptyElement elementTag attrs
785314 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
786− addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
315+ performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
787316 wrapElement defaultDomEventHandler e
317+-}
788318
789319data Link t
790320 = Link { _link_clicked :: Event t ()
791321 }
792322
793−class HasAttributes a where
794− type Attrs a :: *
795− attributes :: Lens' a (Attrs a)
796−
797−instance HasAttributes (ElConfig attrs) where
798− type Attrs (ElConfig attrs) = attrs
799− attributes = elConfig_attributes
800−
801−class HasNamespace a where
802− namespace :: Lens' a (Maybe String)
803−
804−instance HasNamespace (ElConfig attrs) where
805− namespace = elConfig_namespace
806−
807−class HasDomEvent t a where
808− domEvent :: EventName en -> a -> Event t (EventResultType en)
809−
810−instance Reflex t => HasDomEvent t (El t) where
811− domEvent en e = fmap unEventResult $ Reflex.select (_el_events e) (WrapArg en)
812−
813−linkClass :: MonadWidget t m => String -> String -> m (Link t)
323+linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
814324linkClass s c = do
815325 (l,_) <- elAttr' "a" ("class" =: c) $ text s
816326 return $ Link $ domEvent Click l
817327
818−link :: MonadWidget t m => String -> m (Link t)
328+link :: DomBuilder t m => Text -> m (Link t)
819329link s = linkClass s ""
820330
821−button :: MonadWidget t m => String -> m (Event t ())
822−button s = do
823− (e, _) <- elAttr' "button" (Map.singleton "type" "button") $ text s
824− return $ domEvent Click e
825−
826331newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
827332
828−workflow :: forall t m a. MonadWidget t m => Workflow t m a -> m (Dynamic t a)
333+workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
829334workflow w0 = do
830335 rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ fmap snd $ current eResult
831336 mapDyn fst eResult
832337
833−workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
338+workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
834339workflowView w0 = do
835340 rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
836341 eReplace <- liftM switch $ hold never $ fmap snd eResult
837342 return $ fmap fst eResult
838343
839−mapWorkflow :: (MonadWidget t m) => (a -> b) -> Workflow t m a -> Workflow t m b
344+mapWorkflow :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b
840345mapWorkflow f (Workflow x) = Workflow (fmap (\(v,e) -> (f v, fmap (mapWorkflow f) e)) x)
841346
842−divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
347+divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
843348divClass = elClass "div"
844349
845−dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
350+dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a
846351dtdd h w = do
847352 el "dt" $ text h
848353 el "dd" $ w
849354
850−blank :: forall t m. MonadWidget t m => m ()
355+blank :: forall m. Monad m => m ()
851356blank = return ()
852357
853358-- | A widget to display a table with static columns and dynamic rows.
854−tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k)
855− => String -- ^ Class applied to <table> element
856− -> [(String, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
359+tableDynAttr :: forall t m r k v. (DomBuilder t m, MonadHold t m, PostBuild t m)
360+ => Text -- ^ Class applied to <table> element
361+ -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
857362 -> Dynamic t (Map k r) -- ^ Map from row key to row value
858− -> (k -> m (Dynamic t (Map String String))) -- ^ Function to compute <tr> element attributes from row key
859− -> m (Dynamic t (Map k (El t, [v]))) -- ^ Map from row key to (El, list of widget return values)
363+ -> (k -> m (Dynamic t (Map Text Text))) -- ^ Function to compute <tr> element attributes from row key
364+ -> m (Dynamic t (Map k (Element EventResult (DomBuilderSpace m) t, [v]))) -- ^ Map from row key to (El, list of widget return values)
860365tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
861366 elAttr "table" (Map.singleton "class" klass) $ do
862367 el "thead" $ el "tr" $ do
@@ -870,10 +375,10 @@ tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zo
870375-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
871376-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
872377-- the corresponding child and hides all others.
873−tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k)
874− => String -- ^ Class applied to <ul> element
875− -> String -- ^ Class applied to currently active <li> element
876− -> Map k (String, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)
378+tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)
379+ => Text -- ^ Class applied to <ul> element
380+ -> Text -- ^ Class applied to currently active <li> element
381+ -> Map k (Text, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)
877382 -> m ()
878383tabDisplay ulClass activeClass tabItems = do
879384 let t0 = listToMaybe $ Map.keys tabItems
@@ -888,34 +393,13 @@ tabDisplay ulClass activeClass tabItems = do
888393 elDynAttr "div" attrs w
889394 return ()
890395 where
891− headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k)
396+ headerBarLink :: Text -> k -> Dynamic t Bool -> m (Event t k)
892397 headerBarLink x k isSelected = do
893398 attrs <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) isSelected
894399 elDynAttr "li" attrs $ do
895400 a <- link x
896401 return $ fmap (const k) (_link_clicked a)
897402
898−-- | 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.
899−unsafePlaceElement :: MonadWidget t m => Element -> m (El t)
900−unsafePlaceElement e = do
901− p <- askParent
902− _ <- appendChild p $ Just e
903− wrapElement defaultDomEventHandler e
904−
905−deriveGEq ''EventName
906−deriveGCompare ''EventName
907−
908−--------------------------------------------------------------------------------
909−-- Deprecated functions
910−
911−{-# DEPRECATED _el_clicked "Use `domEvent Click` instead" #-}
912−_el_clicked :: Reflex t => El t -> Event t ()
913−_el_clicked = domEvent Click
914−
915−{-# DEPRECATED _el_keypress "Use `domEvent Keypress` instead" #-}
916−_el_keypress :: Reflex t => El t -> Event t Int
917−_el_keypress = domEvent Keypress
918−
919−{-# DEPRECATED _el_scrolled "Use `domEvent Scroll` instead" #-}
920−_el_scrolled :: Reflex t => El t -> Event t Int
921−_el_scrolled = domEvent Scroll
403+class HasAttributes a where
404+ type Attrs a :: *
405+ attributes :: Lens' a (Attrs a)