@@ -88,6 +88,11 @@ runFrameWithTriggerRef r a = do
8888 runWithActions <- askRunWithActions
8989 liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef r
9090
91+runFrameWithTriggerRefNow :: (HasPostGui t m m, MonadRef m, MonadIO m) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()
92+runFrameWithTriggerRefNow r a = do
93+ runWithActions <- askRunWithActions
94+ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef r
95+
9196instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where
9297 askPostGui = lift askPostGui
9398 askRunWithActions = lift askRunWithActions
@@ -150,326 +155,3 @@ getPostBuild = do
150155 (e, trigger) <- newEventWithTriggerRef
151156 schedulePostBuild $ runFrameWithTriggerRef trigger ()
152157 return e
153−
154−--------------------------------------------------------------------------------
155−--------------------------------------------------------------------------------
156−{-
157−
158−class HasRunFrame t m | m -> t where
159− askRunFrame :: m (DMap (EventTrigger t) -> IO ())
160−
161−type MonadWidget t h m = (MonadWidget' t h m, MonadWidget' t h (WidgetEventM m))
162−
163−--TODO: Remove Spider hardcoding
164−class (t ~ Spider, Reflex t, MonadHold t m, ReflexHost t, HasRunFrame t h, MonadReflexHost t h, MonadIO h, MonadRef h, Ref h ~ IORef, MonadFix h, HasDocument h, MonadSample t (WidgetEventM m), WidgetEventM m ~ WidgetEventM (WidgetEventM m), MonadFix m) => MonadWidget' t h m | m -> t h where
165−
166− type WidgetEventM m :: * -> *
167− -- | Warning: dAttributes should not contain "id" attributes
168− elDynAttr' :: String -> Dynamic t (Map String String) -> m a -> m (El t, a)
169− performEvent :: Event t (h a) -> m (Event t a)
170− performEvent_ :: Event t (h ()) -> m ()
171− getEInit :: m (Event t ())
172− putEChildren :: Event t [Node] -> m ()
173− dyn :: Dynamic t (WidgetEventM m a) -> m (Event t a) --TODO: Should probably return Dynamic t a
174− listWithKey :: (Ord k, Show k) => Dynamic t (Map k v) -> (k -> Dynamic t v -> WidgetEventM m v') -> m (Dynamic t (Map k v'))
175− text :: String -> m ()
176− dynText :: Dynamic t String -> m ()
177−
178−{-# INLINABLE performEventAsync #-}
179−performEventAsync :: forall t h m a. (MonadWidget t h m) => Event t ((a -> IO ()) -> h ()) -> m (Event t a)
180−performEventAsync eAction = do
181− let setup mAction = do
182− (eResult, reResultTrigger) <- newEventWithTriggerRef
183− runFrame <- askRunFrame
184− let runAction a = a $ \x -> readRef reResultTrigger >>= mapM_ (\eResultTrigger -> runFrame $ DMap.singleton eResultTrigger x)
185− maybe (return ()) runAction mAction
186− return (eResult, runAction)
187− eSetup <- performEvent . fmap (setup . (^?here)) . align eAction =<< getEInit
188− dRunAction <- holdDyn Nothing $ fmap (Just . snd) eSetup
189− performEvent_ $ attachDynWith (\mRunAction a -> maybe (return ()) ($ a) mRunAction) dRunAction eAction -- Note: this will never fire while eInit is firing, but that situation should be handled in setup; this relies on all the results from the first performEvent being fired simultaneously; otherwise, an eAction could potentially sneak in between setup being sent to performEvent and the result coming back
190− switchPromptly never (fmap fst eSetup)
191−
192−data TextInput t
193− = TextInput { _textInput_value :: Dynamic t String
194− , _textInput_keypress :: Event t Int
195− , _textInput_keydown :: Event t Int
196− , _textInput_keyup :: Event t Int
197− , _textInput_hasFocus :: Dynamic t Bool
198− , _textInput_element :: Dynamic t (Maybe HTMLInputElement)
199− }
200−
201−textInputGetEnter :: Reflex t => TextInput t -> Event t ()
202−textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i
203−
204−setElementAttributes :: IsElement self => self -> Map String String -> IO ()
205−setElementAttributes e attrs = do
206− oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
207− forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet attrs) $ elementRemoveAttribute e
208− iforM_ attrs $ elementSetAttribute e
209−
210−wrapDomEvent :: (HasRunFrame t h, MonadIO m, MonadReflexHost t h, MonadIO h) => e -> (e -> m () -> IO (IO ())) -> m a -> h (Event t a)
211−wrapDomEvent self elementOnevent getValue = do
212− runFrame <- askRunFrame
213− e <- newEventWithTrigger $ \et -> do
214− unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent self $ {-# SCC "c" #-} do
215− v <- {-# SCC "d" #-} getValue
216− liftIO $ runFrame $ DMap.singleton et v
217− return $ liftIO $ do
218− {-# SCC "e" #-} unsubscribe
219− return $! {-# SCC "f" #-} e
220−
221−{-# INLINABLE input #-}
222−input' :: MonadWidget t h m => String -> Event t String -> Dynamic t (Map String String) -> m (TextInput t)
223−input' inputType eSetValue dAttrs = do
224− dEffectiveAttrs <- mapDyn (Map.insert "type" inputType) dAttrs
225− let mkSelf (initialValue, initialAttrs) = do
226− doc <- askDocument
227− Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
228− liftIO $ htmlInputElementSetValue e initialValue
229− iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
230− eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e
231− runFrame <- askRunFrame
232− eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
233− unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
234− runFrame $ DMap.singleton eChangeFocusTrigger False
235− unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
236− runFrame $ DMap.singleton eChangeFocusTrigger True
237− return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
238− eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
239− eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event
240− eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event
241− return (e, eChange, eKeypress, eKeydown, eKeyup, eChangeFocus)
242− dInitialValue <- holdDyn "" eSetValue
243− dInitial <- combineDyn (,) dInitialValue dEffectiveAttrs
244− eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
245− dMyElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
246− performEvent_ . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dEffectiveAttrs
247− putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated
248− performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlInputElementSetValue e v) $ attachWith (\e v -> case e of
249− Nothing -> Nothing
250− Just e' -> Just (e',v)) (current dMyElement) eSetValue
251− eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
252− dFocus <- holdDyn False . switch =<< hold never (fmap (^. _6) eCreated) --TODO: Check that 'False' is always the correct starting value - i.e.: an element will always receive an 'onfocus' event, even if it gets focus immediately
253− dValue <- holdDyn "" $ leftmost [eSetValue, eChange]
254− eKeypress <- liftM switch $ hold never $ fmap (^. _3) eCreated
255− eKeydown <- liftM switch $ hold never $ fmap (^. _4) eCreated
256− eKeyup <- liftM switch $ hold never $ fmap (^. _5) eCreated
257− return $ TextInput dValue eKeypress eKeydown eKeyup dFocus dMyElement
258−
259−input :: MonadWidget t h m => String -> Map String String -> m (TextInput t)
260−input t as = input' t never (constDyn as)
261−
262−data TextArea t
263− = TextArea { _textArea_value :: Dynamic t String
264− , _textArea_element :: Dynamic t (Maybe HTMLTextAreaElement)
265− }
266−
267−textArea' :: MonadWidget t h m => Event t String -> Dynamic t (Map String String) -> m (TextArea t)
268−textArea' eSetValue dAttrs = do
269− let mkSelf (initialValue, initialAttrs) = do
270− doc <- askDocument
271− Just e <- liftIO $ liftM (fmap castToHTMLTextAreaElement) $ documentCreateElement doc "textarea"
272− liftIO $ htmlTextAreaElementSetValue e initialValue
273− iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
274− eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e
275− return (e, eChange)
276− dInitialValue <- holdDyn "" eSetValue
277− dInitial <- combineDyn (,) dInitialValue dAttrs
278− eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
279− dMyElement <- holdDyn Nothing $ fmap (Just . fst) eCreated
280− --performEvent . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dAttrs
281− putEChildren $ fmap ((:[]) . toNode . fst) eCreated
282− performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlTextAreaElementSetValue e v) $ attachWith (\e v -> case e of
283− Nothing -> Nothing
284− Just e' -> Just (e',v)) (current dMyElement) eSetValue
285− eChange <- liftM switch $ hold never $ fmap snd eCreated
286− dValue <- holdDyn "" $ leftmost [eSetValue, eChange]
287− return $ TextArea dValue dMyElement
288−
289−
290−data Checkbox t
291− = Checkbox { _checkbox_checked :: Dynamic t Bool
292− }
293−
294−checkbox :: MonadWidget t h m => Bool -> Map String String -> m (Checkbox t)
295−checkbox checked attrs = do
296− let mkSelf = do
297− doc <- askDocument
298− Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
299− liftIO $ elementSetAttribute e "type" "checkbox"
300− iforM_ attrs $ \attr value -> liftIO $ elementSetAttribute e attr value
301− if checked == True then liftIO $ elementSetAttribute e "checked" "true" else return ()
302− eChange <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e
303− return ([toNode e], eChange)
304− eCreated <- performEvent . fmap (const mkSelf) =<< getEInit
305− putEChildren $ fmap (^. _1) eCreated
306− eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
307− dValue <- holdDyn checked eChange
308− return $ Checkbox dValue
309−
310−checkboxView :: MonadWidget t h m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t ())
311−checkboxView dAttrs dValue = do
312− dEffectiveAttrs <- mapDyn (Map.insert "type" "checkbox") dAttrs
313− let mkSelf (initialValue, initialAttrs) = do
314− doc <- askDocument
315− Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
316− iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
317− liftIO $ htmlInputElementSetChecked e initialValue
318− eClicked <- wrapDomEvent e elementOnclick preventDefault
319− return (e, eClicked)
320− dInitial <- combineDyn (,) dValue dEffectiveAttrs
321− eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
322− putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated
323− dElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
324− performEvent_ . updated =<< combineDyn (\me a -> forM_ me $ \e -> liftIO $ setElementAttributes e a) dElement dEffectiveAttrs
325− performEvent_ . updated =<< combineDyn (\v me -> maybe (return ()) (\e -> liftIO $ htmlInputElementSetChecked e v) me) dValue dElement
326− liftM switch $ hold never $ fmap (^. _2) eCreated
327−
328−{-# INLINABLE textInput #-}
329−textInput :: MonadWidget t h m => m (TextInput t)
330−textInput = input "text" $ Map.singleton "class" "form-control"
331−
332−data Dropdown t k
333− = Dropdown { _dropdown_value :: Dynamic t k
334− }
335−
336−setInnerText :: (HasDocument m, IsHTMLElement self, MonadIO m) => self -> String -> m (Maybe Node)
337−setInnerText e s = do
338− liftIO $ htmlElementSetInnerHTML e ""
339− doc <- askDocument
340− t <- liftIO $ documentCreateTextNode doc s
341− liftIO $ nodeAppendChild e t
342−
343−--TODO: Retain set value when allowed values changes
344−{-# INLINABLE dropdown #-}
345−dropdown :: forall t h m k. (MonadWidget t h m, Show k, Read k) => Dynamic t (Map k String) -> m (Dropdown t (Maybe k))
346−dropdown dOptions = do
347− let triggerChange (e, reChangeTrigger) runFrame = do
348− v <- htmlSelectElementGetValue e
349− readRef reChangeTrigger >>= mapM_ (\eChangeTrigger -> runFrame $ DMap.singleton eChangeTrigger $ readMay v)
350− let mkSelf = do
351− doc <- askDocument
352− Just e <- liftIO $ liftM (fmap castToHTMLSelectElement) $ documentCreateElement doc "select"
353− liftIO $ elementSetAttribute e "class" "form-control"
354− runFrame <- askRunFrame
355− reChangeTrigger <- newRef Nothing
356− eChange <- newEventWithTrigger $ \eChangeTrigger -> do
357− writeRef reChangeTrigger $ Just eChangeTrigger
358− unsubscribe <- liftIO $ elementOnchange e $ liftIO $ triggerChange (e, reChangeTrigger) runFrame
359− return $ do
360− writeRef reChangeTrigger Nothing
361− liftIO unsubscribe
362− return ((e, reChangeTrigger), eChange)
363− eCreated <- performEvent . fmap (const mkSelf) =<< getEInit
364− dState <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
365− putEChildren $ fmap ((:[]) . toNode . fst . (^. _1)) eCreated
366− let updateOptions :: Map k String -> Maybe (HTMLSelectElement, Ref h (Maybe (EventTrigger t (Maybe k)))) -> h ()
367− updateOptions options = maybe (return ()) $ \myState@(selectElement, _) -> do
368− doc <- askDocument
369− liftIO $ htmlElementSetInnerHTML selectElement ""
370− iforM_ options $ \k optionText -> do
371− Just optionElement <- liftIO $ liftM (fmap castToHTMLOptionElement) $ documentCreateElement doc "option"
372− liftIO $ elementSetAttribute optionElement "value" $ show k
373− _ <- setInnerText optionElement optionText
374− liftIO $ nodeAppendChild selectElement $ Just optionElement
375− runFrame <- askRunFrame
376− liftIO $ triggerChange myState runFrame
377− performEvent_ . updated =<< combineDyn updateOptions dOptions dState
378− eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
379− dValue <- holdDyn Nothing eChange
380− return $ Dropdown dValue
381−
382−data Link t
383− = Link { _link_clicked :: Event t ()
384− }
385−
386−linkClassWithExtraSetup :: MonadWidget t h m => (HTMLElement -> h ()) -> String -> String -> m (Link t)
387−linkClassWithExtraSetup extraSetup s c = do
388− let mkSelf = do
389− doc <- askDocument
390− Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "a"
391− _ <- setInnerText e s
392− liftIO $ elementSetAttribute e "class" c
393− eClicked <- wrapDomEvent e elementOnclick $ return ()
394− extraSetup e
395− return ([toNode e], eClicked)
396− eCreated <- performEvent . fmap (const mkSelf) =<< getEInit
397− putEChildren $ fmap (^. _1) eCreated
398− eClicked <- liftM switch $ hold never $ fmap (^. _2) eCreated
399− return $ Link eClicked
400−
401−{-# INLINABLE linkClass #-}
402−linkClass :: MonadWidget t h m => String -> String -> m (Link t)
403−linkClass = linkClassWithExtraSetup $ const $ return ()
404−
405−{-# INLINABLE link #-}
406−link :: MonadWidget t h m => String -> m (Link t)
407−link s = linkClass s ""
408−
409−{-# INLINABLE button #-}
410−button :: MonadWidget t h m => String -> m (Link t)
411−button s = linkClass s "btn btn-primary"
412−
413−{-# INLINABLE elAttr #-}
414−elAttr :: forall t h m a. MonadWidget t h m => String -> Map String String -> m a -> m a
415−elAttr elementTag attrs child = liftM snd $ elAttr' elementTag attrs child
416−
417−{-# INLINABLE el' #-}
418−el' :: forall t h m a. MonadWidget t h m => String -> m a -> m (El t, a)
419−el' elementTag child = elAttr' elementTag Map.empty child
420−
421−{-# INLINABLE elAttr' #-}
422−elAttr' :: forall t h m a. MonadWidget t h m => String -> Map String String -> m a -> m (El t, a)
423−elAttr' elementTag attrs child = do
424− dAttributes <- holdDyn attrs never
425− elDynAttr' elementTag dAttributes child
426−
427−{-# INLINABLE elDynAttr #-}
428−elDynAttr :: forall t h m a. MonadWidget t h m => String -> Dynamic t (Map String String) -> m a -> m a
429−elDynAttr elementTag dAttributes child = liftM snd $ elDynAttr' elementTag dAttributes child
430−
431−{-# INLINABLE el #-}
432−el :: forall t h m a. MonadWidget t h m => String -> m a -> m a
433−el elementTag child = elAttr elementTag Map.empty child
434−
435−newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
436−
437−workflowView :: forall t h m a. MonadWidget t h m => Workflow t (WidgetEventM m) a -> m (Event t a)
438−workflowView w0 = do
439− rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
440− eReplace <- liftM switch $ hold never $ fmap snd eResult
441− eResult `seq` eReplace `seq` return ()
442− return $ fmap fst eResult
443−
444−insertNext :: (Ord k, Enum k) => v -> Map k v -> Map k v
445−insertNext v m =
446− let k = case Map.maxViewWithKey m of
447− Nothing -> toEnum 0
448− Just ((k0, _), _) -> succ k0
449− in Map.insert k v m
450−
451−{-# INLINABLE oldList #-}
452−oldList :: (MonadWidget t h m, MonadWidget t h (WidgetEventM m), Ord k, Show k) => Dynamic t (Map k (WidgetEventM m v')) -> m (Dynamic t (Map k ()))
453−oldList dm = el "ul" $ list dm (\dv -> el "li" (dyn dv) >> return ())
454−
455−{-# INLINABLE list #-}
456−list :: forall t m h k v v'. (MonadWidget t h m, Ord k, Show k) => Dynamic t (Map k v) -> (Dynamic t v -> WidgetEventM m v') -> m (Dynamic t (Map k v'))
457−list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
458−
459−instance MonadWidget' t h m => MonadWidget' t h (ReaderT r m) where
460− type WidgetEventM (ReaderT r m) = ReaderT r (WidgetEventM m)
461− elDynAttr' tag dAttrs = mapReaderT (elDynAttr' tag dAttrs)
462− performEvent = lift . performEvent
463− performEvent_ = lift . performEvent_
464− getEInit = lift getEInit
465− putEChildren = lift . putEChildren
466− dyn d = do
467− r <- ask
468− lift $ dyn =<< mapDyn (flip runReaderT r) d
469− listWithKey d w = do
470− r <- ask
471− lift $ listWithKey d $ \k dv -> runReaderT (w k dv) r
472− text = lift . text
473− dynText = lift . dynText
474−
475−-}