git.iko.soy/reflex-dom
on 022ff15 help sign in
reflex-dom/src/Reflex/Dom/Widget/Basic.hs
437 lines 19 kB history raw
1{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo #-}
3module Reflex.Dom.Widget.Basic where
5import Reflex.Dom.Class
7import Reflex
8import Reflex.Host.Class
9import Data.Functor.Misc
10import Data.Map (Map)
11import qualified Data.Map as Map
12import Data.Set (Set)
13import qualified Data.Set as Set
14import Data.Dependent.Sum (DSum (..))
15import Control.Monad.Trans
16import Control.Monad.Reader
17import Control.Monad.Ref
18import GHCJS.DOM.Node
19import GHCJS.DOM.UIEvent
20import GHCJS.DOM.EventM (event, Signal)
21import GHCJS.DOM.Document
22import GHCJS.DOM.Element
23import GHCJS.DOM.HTMLElement
24import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)
25import GHCJS.DOM.NamedNodeMap
26import Control.Lens
27import Data.Monoid
28import Data.These
29import Data.Align
31import Data.Maybe
33type AttributeMap = Map String String
35data El t
36 = El { _el_element :: HTMLElement
37 , _el_clicked :: Event t ()
38 , _el_keypress :: Event t Int
39 , _el_scrolled :: Event t Int
40 }
42class Attributes m a where
43 addAttributes :: IsElement e => a -> e -> m ()
45instance MonadIO m => Attributes m AttributeMap where
46 addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs
48instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
49 addAttributes attrs e = do
50 schedulePostBuild $ do
51 curAttrs <- sample $ current attrs
52 liftIO $ imapM_ (elementSetAttribute e) curAttrs
53 addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do
54 oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
55 forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
56 imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
58buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement
59buildEmptyElement elementTag attrs = do
60 doc <- askDocument
61 p <- askParent
62 Just e <- liftIO $ documentCreateElement doc elementTag
63 addAttributes attrs e
64 _ <- liftIO $ nodeAppendChild p $ Just e
65 return $ castToHTMLElement e
67-- 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
68buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)
69buildElement elementTag attrs child = do
70 e <- buildEmptyElement elementTag attrs
71 result <- subWidget (toNode e) child
72 return (e, result)
74namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
75namedNodeMapGetNames self = do
76 l <- namedNodeMapGetLength self
77 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
78 liftM Set.fromList $ forM locations $ \i -> do
79 Just n <- namedNodeMapItem self i
80 nodeGetNodeName n
82text :: MonadWidget t m => String -> m ()
83text = void . text'
85--TODO: Wrap the result
86text' :: MonadWidget t m => String -> m Text
87text' s = do
88 doc <- askDocument
89 p <- askParent
90 Just n <- liftIO $ documentCreateTextNode doc s
91 _ <- liftIO $ nodeAppendChild p $ Just n
92 return n
94dynText :: MonadWidget t m => Dynamic t String -> m ()
95dynText s = do
96 n <- text' ""
97 schedulePostBuild $ do
98 curS <- sample $ current s
99 liftIO $ nodeSetNodeValue n curS
100 addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s
102--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
103dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
104dyn child = do
105 startPlaceholder <- text' ""
106 endPlaceholder <- text' ""
107 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
108 let e = fmap snd newChildBuilt --TODO: Get rid of this hack
109 childVoidAction <- hold never e
110 performEvent_ $ fmap (const $ return ()) e --TODO: Get rid of this hack
111 addVoidAction $ switch childVoidAction
112 doc <- askDocument
113 runWidget <- getRunWidget
114 let build c = do
115 Just df <- liftIO $ documentCreateDocumentFragment doc
116 result <- runWidget df c
117 runFrameWithTriggerRef newChildBuiltTriggerRef result
118 Just p <- liftIO $ nodeGetParentNode endPlaceholder
119 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
120 return ()
121 schedulePostBuild $ do
122 c <- sample $ current child
123 build c
124 addVoidAction $ ffor (updated child) $ \newChild -> do
125 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
126 build newChild
127 return $ fmap fst newChildBuilt
129widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
130widgetHold child0 newChild = do
131 startPlaceholder <- text' ""
132 result0 <- child0
133 endPlaceholder <- text' ""
134 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
135 childVoidAction <- hold never $ fmap snd newChildBuilt
136 addVoidAction $ switch childVoidAction
137 doc <- askDocument
138 runWidget <- getRunWidget
139 let build c = do
140 Just df <- liftIO $ documentCreateDocumentFragment doc
141 result <- runWidget df c
142 runFrameWithTriggerRef newChildBuiltTriggerRef result
143 Just p <- liftIO $ nodeGetParentNode endPlaceholder
144 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
145 return ()
146 addVoidAction $ ffor newChild $ \c -> do
147 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
148 build c
149 holdDyn result0 $ fmap fst newChildBuilt
151--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
152listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
153listWithKey vals mkChild = do
154 doc <- askDocument
155 startPlaceholder <- text' ""
156 endPlaceholder <- text' ""
157 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
158 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
159 children <- hold Map.empty $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren
160 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
161 runWidget <- getRunWidget
162 let buildChild df k v = runWidget df $ do
163 childStart <- text' ""
164 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
165 childEnd <- text' ""
166 return (result, (childStart, childEnd))
167 schedulePostBuild $ do
168 Just df <- liftIO $ documentCreateDocumentFragment doc
169 curVals <- sample $ current vals
170 initialState <- iforM curVals $ buildChild df
171 runFrameWithTriggerRef newChildrenTriggerRef initialState --TODO: Do all these in a single runFrame
172 Just p <- liftIO $ nodeGetParentNode endPlaceholder
173 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
174 return ()
175 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
176 curState <- sample children
177 --TODO: Should we remove the parent from the DOM first to avoid reflows?
178 newState <- liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
179 This ((_, (start, end)), _) -> do
180 liftIO $ putStrLn "Deleting item"
181 liftIO $ deleteBetweenInclusive start end
182 return Nothing
183 That v -> do
184 liftIO $ putStrLn "Creating item"
185 Just df <- liftIO $ documentCreateDocumentFragment doc
186 s <- buildChild df k v
187 let placeholder = case Map.lookupGT k curState of
188 Nothing -> endPlaceholder
189 Just (_, ((_, (start, _)), _)) -> start
190 Just p <- liftIO $ nodeGetParentNode placeholder
191 liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
192 return $ Just s
193 These state _ -> do
194 liftIO $ putStrLn "Leaving item unchanged"
195 return $ Just state
196 liftIO $ putStrLn "Triggering newChildren"
197 liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef
198 runFrameWithTriggerRef newChildrenTriggerRef newState
199 liftIO $ putStrLn "Triggering newChildren done"
200 holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren
202listWithKey' :: forall t m k v a. (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
203listWithKey' initialVals valsChanged mkChild = do
204 doc <- askDocument
205 startPlaceholder <- text' ""
206 endPlaceholder <- text' ""
207 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
208-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
209 runWidget <- getRunWidget
210 let childValChangedSelector :: EventSelector t (Const2 k v)
211 childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
212 buildChild :: DocumentFragment -> k -> v -> WidgetHost m ((a, (Text, Text)), Event t (WidgetHost m ()))
213 buildChild df k v = runWidget df $ wrapChild k v
214 wrapChild k v = do
215 childStart <- text' ""
216 result <- mkChild k v $ select childValChangedSelector $ Const2 k
217 childEnd <- text' ""
218 return (result, (childStart, childEnd))
219 Just df <- liftIO $ documentCreateDocumentFragment doc
220 initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode df) $ 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
221 children <- holdDyn initialState $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren
222 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
223 Just p <- liftIO $ nodeGetParentNode endPlaceholder
224 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
225 addVoidAction $ flip fmap valsChanged $ \newVals -> do
226 curState <- sample $ current children
227 --TODO: Should we remove the parent from the DOM first to avoid reflows?
228 newState <- liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
229 These ((_, (start, end)), _) Nothing -> do -- Deleting child
230 liftIO $ deleteBetweenInclusive start end
231 return Nothing
232 These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child
233 liftIO $ deleteBetweenExclusive start end
234 Just df <- liftIO $ documentCreateDocumentFragment doc
235 s <- buildChild df k v
236 Just p <- liftIO $ nodeGetParentNode end
237 liftIO $ nodeInsertBefore p (Just df) (Just end)
238 return $ Just s
239 That Nothing -> return Nothing -- Deleting non-existent child
240 That (Just v) -> do -- Creating new child
241 Just df <- liftIO $ documentCreateDocumentFragment doc
242 s <- buildChild df k v
243 let placeholder = case Map.lookupGT k curState of
244 Nothing -> endPlaceholder
245 Just (_, ((_, (start, _)), _)) -> start
246 Just p <- liftIO $ nodeGetParentNode placeholder
247 liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
248 return $ Just s
249 This state -> do -- No change
250 return $ Just state
251 liftIO $ putStrLn "Triggering newChildren"
252 liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef
253 runFrameWithTriggerRef newChildrenTriggerRef newState
254 liftIO $ putStrLn "Triggering newChildren done"
255 mapDyn (fmap (fst . fst)) children
257selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k) => Dynamic t k -> Dynamic t (Map k v) -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -> m (Event t k)
258selectViewListWithKey_ selection vals mkChild = do
259 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
260 selectChild <- listWithKey vals $ \k v -> do
261 selected <- getDemuxed selectionDemux k
262 selectSelf <- mkChild k v selected
263 return $ fmap (const k) selectSelf
264 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
266--------------------------------------------------------------------------------
267-- Basic DOM manipulation helpers
268--------------------------------------------------------------------------------
270-- | s and e must both be children of the same node and s must precede e
271deleteBetweenExclusive s e = do
272 Just currentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
273 let go = do
274 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
275 when (unNode (toNode s) /= unNode (toNode x)) $ do
276 nodeRemoveChild currentParent $ Just x
277 go
278 go
280-- | s and e must both be children of the same node and s must precede e
281deleteBetweenInclusive s e = do
282 Just currentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
283 let go = do
284 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
285 nodeRemoveChild currentParent $ Just x
286 when (unNode (toNode s) /= unNode (toNode x)) go
287 go
288 nodeRemoveChild currentParent $ Just e
290--------------------------------------------------------------------------------
291-- Adapters
292--------------------------------------------------------------------------------
294--TODO: Get rid of extra version of this function
295wrapDomEvent element elementOnevent getValue = do
296 postGui <- askPostGui
297 runWithActions <- askRunWithActions
298 e <- newEventWithTrigger $ \et -> do
299 unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
300 v <- {-# SCC "d" #-} getValue
301 liftIO $ postGui $ runWithActions [et :=> v]
302 return $ liftIO $ do
303 {-# SCC "e" #-} unsubscribe
304 return $! {-# SCC "f" #-} e
306wrapElement :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
307wrapElement e = do
308 clicked <- wrapDomEvent e elementOnclick (return ())
309 keypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
310 scrolled <- wrapDomEvent e elementOnscroll $ liftIO $ elementGetScrollTop e
311 return $ El e clicked keypress scrolled
313elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
314elDynAttr' elementTag attrs child = do
315 (e, result) <- buildElement elementTag attrs child
316 e' <- wrapElement e
317 return (e', result)
319{-# INLINABLE elAttr #-}
320elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
321elAttr elementTag attrs child = do
322 (_, result) <- buildElement elementTag attrs child
323 return result
325{-# INLINABLE el' #-}
326el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
327el' tag child = elAttr' tag (Map.empty :: AttributeMap) child
329{-# INLINABLE elAttr' #-}
330elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
331elAttr' elementTag attrs child = do
332 (e, result) <- buildElement elementTag attrs child
333 e' <- wrapElement e
334 return (e', result)
336{-# INLINABLE elDynAttr #-}
337elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
338elDynAttr elementTag attrs child = do
339 (_, result) <- buildElement elementTag attrs child
340 return result
342{-# INLINABLE el #-}
343el :: forall t m a. MonadWidget t m => String -> m a -> m a
344el tag child = elAttr tag Map.empty child
346elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
347elClass tag c child = elAttr tag ("class" =: c) child
349--------------------------------------------------------------------------------
350-- Copied and pasted from Reflex.Widget.Class
351--------------------------------------------------------------------------------
353list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
355{-
357--TODO: Update dynamically
358{-# INLINABLE dynHtml #-}
359dynHtml :: MonadWidget t m => Dynamic t String -> m ()
360dynHtml ds = do
361 let mkSelf h = do
362 doc <- askDocument
363 Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "div"
364 liftIO $ htmlElementSetInnerHTML e h
365 return e
366 eCreated <- performEvent . fmap mkSelf . tagDyn ds =<< getEInit
367 putEChildren $ fmap ((:[]) . toNode) eCreated
369-}
371data Link t
372 = Link { _link_clicked :: Event t ()
373 }
375linkClass :: MonadWidget t m => String -> String -> m (Link t)
376linkClass s c = do
377 (l,_) <- elAttr' "a" ("class" =: c) $ text s
378 return $ Link $ _el_clicked l
380link :: MonadWidget t m => String -> m (Link t)
381link s = linkClass s ""
383newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
385workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
386workflowView w0 = do
387 rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
388 eReplace <- liftM switch $ hold never $ fmap snd eResult
389 eResult `seq` eReplace `seq` return ()
390 return $ fmap fst eResult
392divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
393divClass = elClass "div"
395dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
396dtdd h w = do
397 el "dt" $ text h
398 el "dd" $ w
400blank :: forall t m. MonadWidget t m => m ()
401blank = return ()
403tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k) => String -> [(String, k -> Dynamic t r -> m v)] -> Dynamic t (Map k r) -> (k -> m (Dynamic t (Map String String))) -> m (Dynamic t (Map k (El t, [v])))
404tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
405 elAttr "table" (Map.singleton "class" klass) $ do
406 el "thead" $ el "tr" $ do
407 mapM (\(h, _) -> el "th" $ text h) cols
408 el "tbody" $ do
409 listWithKey dRows (\k r -> do
410 dAttrs <- rowAttrs k
411 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
413--TODO preselect a tab on open
414tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
415tabDisplay ulClass activeClass tabItems = do
416 rec dCurrentTab <- holdDyn Nothing (updated dTabClicks)
417 dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do
418 tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< mapDyn (== (Just k)) dCurrentTab) tabItems
419 let eTabClicks :: Event t k = leftmost tabClicksList
420 holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))
421 divClass "" $ do
422 let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems
423 listWithKey dTabs (\k dTab -> do
424 dAttrs <- mapDyn (\sel -> do
425 let t1 = listToMaybe $ Map.keys tabItems
426 if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab
427 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
428 return ()
429 where
430 headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k)
431 headerBarLink x k dBool = do
432 dAttributes <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) dBool
433 elDynAttr "li" dAttributes $ do
434 a <- link x
435 return $ fmap (const k) (_link_clicked a)