git.iko.soy/reflex-dom
on develop help sign in
Initial commit
commit0204971a9292c0142c4bf11cb077b9194fb459f6 authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 31 Jan 2015, 14:15 (12 years ago)
11 files changed+1393
compare with develop
unifiedsplit
.ghci+3 .gitignore+31 LICENSE default.nix+28 reflex-dom.cabal+43 src/Reflex/Dom.hs+8 src/Reflex/Dom/Class.hs+440 src/Reflex/Dom/Internal.hs+205 src/Reflex/Dom/Widget.hs+6 src/Reflex/Dom/Widget/Basic.hs+375 src/Reflex/Dom/Widget/Input.hs+254
.ghcinew file+3
@@ -0,0 +1,3 @@
1+:set -isrc
2+:set -hide-package MonadCatchIO-mtl
3+:set -hide-package monads-fd
.gitignorenew file+31
@@ -0,0 +1,31 @@
1+dist
2+cabal-dev
3+*.o
4+*.hi
5+*.chi
6+*.chs.h
7+*.dyn_hi
8+*.dyn_o
9+*.p_hi
10+*.p_o
11+*.js_dyn_hi
12+*.js_dyn_o
13+*.js_p_hi
14+*.js_p_o
15+*.js_o
16+*.js_hi
17+.virthualenv
18+.hsenv*
19+*.*~
20+*.swp
21+.DS_Store
22+backend.pid
23+backend.out
24+.shelly
25+TAGS
26+tags
27+*~
28+*.orig
29+hsenv.log
30+\#*#
31+.#*
LICENSEnew file

No changes to the content.

default.nixnew file+28
@@ -0,0 +1,28 @@
1+{ cabal, dependentMap, ghcjsDom, lens
2+, mtl, reflex, safe, text, these
3+, transformers, dataDefault, semigroups
4+}:
5+
6+cabal.mkDerivation (self: {
7+ pname = "reflex-dom";
8+ version = "0.1";
9+ src = ./.;
10+ buildDepends = [
11+ reflex
12+ dependentMap
13+ mtl
14+ transformers
15+ these
16+ lens
17+ ghcjsDom
18+ safe
19+ text
20+ dataDefault
21+ semigroups
22+ ];
23+ meta = {
24+ description = "Functional Reactive DOM widgets";
25+ license = self.stdenv.lib.licenses.unfree;
26+ platforms = self.ghc.meta.platforms;
27+ };
28+})
reflex-dom.cabalnew file+43
@@ -0,0 +1,43 @@
1+Name: reflex-dom
2+Version: 0.1
3+Synopsis: Glitch-free Functional Reactive Programming
4+Description: Reflex is a Functional Reactive Programming implementation that provides strong guarantees of deterministic execution and scalable runtime performance
5+License: AllRightsReserved
6+License-file: LICENSE
7+Author: Ryan Trinkle
8+Maintainer: ryan.trinkle@gmail.com
9+Stability: Experimental
10+Category: FRP
11+Build-type: Simple
12+Cabal-version: >=1.2
13+
14+library
15+ hs-source-dirs: src
16+ build-depends:
17+ base,
18+ reflex,
19+ dependent-map,
20+ dependent-sum,
21+ mtl,
22+ transformers,
23+ containers,
24+ these,
25+ lens,
26+ ghcjs-dom,
27+ safe,
28+ text,
29+ bytestring,
30+ data-default,
31+ semigroups
32+
33+ exposed-modules:
34+ Reflex.Dom
35+ Reflex.Dom.Class
36+ Reflex.Dom.Internal
37+ Reflex.Dom.Widget
38+ Reflex.Dom.Widget.Basic
39+ Reflex.Dom.Widget.Input
40+
41+ other-extensions: TemplateHaskell
42+ ghc-prof-options: -fprof-auto
43+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
src/Reflex/Dom.hsnew file+8
@@ -0,0 +1,8 @@
1+module Reflex.Dom ( module Reflex.Dom.Class
2+ , module Reflex.Dom.Internal
3+ , module Reflex.Dom.Widget
4+ ) where
5+
6+import Reflex.Dom.Class
7+import Reflex.Dom.Internal
8+import Reflex.Dom.Widget
src/Reflex/Dom/Class.hsnew file+440
@@ -0,0 +1,440 @@
1+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TemplateHaskell, PolyKinds, TypeOperators, DeriveFunctor, LambdaCase, CPP, ForeignFunctionInterface, DeriveDataTypeable, ConstraintKinds #-}
2+module Reflex.Dom.Class where
3+
4+import Prelude hiding (mapM, mapM_, sequence, concat)
5+
6+import Reflex
7+import Reflex.Host.Class
8+
9+import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence)
10+import Control.Lens hiding ((<|))
11+import Data.Set (Set)
12+import qualified Data.Set as Set
13+import Data.Map (Map)
14+import qualified Data.Map as Map
15+import Data.Traversable
16+import Data.Foldable
17+import Control.Monad.Ref
18+import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence)
19+import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)
20+import qualified Data.Dependent.Map as DMap
21+import Data.Dependent.Sum (DSum (..))
22+import Data.IORef
23+import Data.These
24+import Data.Align
25+import GHCJS.DOM.Types hiding (Event)
26+import GHCJS.DOM.Document
27+import GHCJS.DOM.Node
28+import GHCJS.DOM.NamedNodeMap
29+import GHCJS.DOM.Element
30+import GHCJS.DOM.HTMLElement
31+import GHCJS.DOM.HTMLInputElement
32+import GHCJS.DOM.HTMLSelectElement
33+import GHCJS.DOM.HTMLTextAreaElement
34+import GHCJS.DOM.UIEvent
35+import GHCJS.DOM.EventM (event, preventDefault)
36+import Data.Dependent.Map (DMap)
37+import Safe
38+
39+-- | Alias for Data.Map.singleton
40+(=:) :: k -> a -> Map k a
41+(=:) = Map.singleton
42+
43+keycodeEnter :: Int
44+keycodeEnter = 13
45+
46+keycodeEscape :: Int
47+keycodeEscape = 27
48+
49+class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m
50+ , HasDocument m
51+ , MonadIO (WidgetHost m), Functor (WidgetHost m), MonadSample t (WidgetHost m)
52+ , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, MonadRef m, MonadRef (WidgetHost m)
53+ , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO
54+ , MonadFix m
55+ ) => MonadWidget t m | m -> t where
56+ type WidgetHost m :: * -> *
57+ type GuiAction m :: * -> *
58+ askParent :: m Node
59+ subWidget :: Node -> m a -> m a
60+ schedulePostBuild :: WidgetHost m () -> m ()
61+ addVoidAction :: Event t (WidgetHost m ()) -> m ()
62+ getRunWidget :: IsNode n => m (n -> m a -> WidgetHost m (a, Event t (WidgetHost m ())))
63+
64+class Monad m => HasDocument m where
65+ askDocument :: m HTMLDocument
66+
67+instance HasDocument m => HasDocument (ReaderT r m) where
68+ askDocument = lift askDocument
69+
70+instance HasDocument m => HasDocument (StateT r m) where
71+ askDocument = lift askDocument
72+
73+class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where
74+ askPostGui :: m (h () -> IO ())
75+ askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())
76+
77+runFrameWithTriggerRef :: (HasPostGui t h m, MonadRef m, MonadIO m) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()
78+runFrameWithTriggerRef r a = do
79+ postGui <- askPostGui
80+ runWithActions <- askRunWithActions
81+ liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef r
82+
83+instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where
84+ askPostGui = lift askPostGui
85+ askRunWithActions = lift askRunWithActions
86+
87+instance MonadWidget t m => MonadWidget t (ReaderT r m) where
88+ type WidgetHost (ReaderT r m) = WidgetHost m
89+ type GuiAction (ReaderT r m) = GuiAction m
90+ askParent = lift askParent
91+ subWidget n w = do
92+ r <- ask
93+ lift $ subWidget n $ runReaderT w r
94+ schedulePostBuild = lift . schedulePostBuild
95+ addVoidAction = lift . addVoidAction
96+ getRunWidget = do
97+ r <- ask
98+ runWidget <- lift getRunWidget
99+ return $ \rootElement w -> runWidget rootElement $ runReaderT w r
100+
101+performEvent_ = addVoidAction
102+
103+performEvent e = do
104+ (eResult, reResultTrigger) <- newEventWithTriggerRef
105+ addVoidAction $ ffor e $ \o -> do
106+ result <- o
107+ runFrameWithTriggerRef reResultTrigger result
108+ return eResult
109+
110+performEventAsync :: forall t m a. MonadWidget t m => Event t ((a -> IO ()) -> WidgetHost m ()) -> m (Event t a)
111+performEventAsync e = do
112+ (eResult, reResultTrigger) <- newEventWithTriggerRef
113+ addVoidAction $ ffor e $ \o -> do
114+ postGui <- askPostGui
115+ runWithActions <- askRunWithActions
116+ o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef reResultTrigger
117+ return eResult
118+
119+--------------------------------------------------------------------------------
120+--------------------------------------------------------------------------------
121+{-
122+
123+class HasRunFrame t m | m -> t where
124+ askRunFrame :: m (DMap (EventTrigger t) -> IO ())
125+
126+type MonadWidget t h m = (MonadWidget' t h m, MonadWidget' t h (WidgetEventM m))
127+
128+--TODO: Remove Spider hardcoding
129+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
130+
131+ type WidgetEventM m :: * -> *
132+ -- | Warning: dAttributes should not contain "id" attributes
133+ elDynAttr' :: String -> Dynamic t (Map String String) -> m a -> m (El t, a)
134+ performEvent :: Event t (h a) -> m (Event t a)
135+ performEvent_ :: Event t (h ()) -> m ()
136+ getEInit :: m (Event t ())
137+ putEChildren :: Event t [Node] -> m ()
138+ dyn :: Dynamic t (WidgetEventM m a) -> m (Event t a) --TODO: Should probably return Dynamic t a
139+ listWithKey :: (Ord k, Show k) => Dynamic t (Map k v) -> (k -> Dynamic t v -> WidgetEventM m v') -> m (Dynamic t (Map k v'))
140+ text :: String -> m ()
141+ dynText :: Dynamic t String -> m ()
142+
143+{-# INLINABLE performEventAsync #-}
144+performEventAsync :: forall t h m a. (MonadWidget t h m) => Event t ((a -> IO ()) -> h ()) -> m (Event t a)
145+performEventAsync eAction = do
146+ let setup mAction = do
147+ (eResult, reResultTrigger) <- newEventWithTriggerRef
148+ runFrame <- askRunFrame
149+ let runAction a = a $ \x -> readRef reResultTrigger >>= mapM_ (\eResultTrigger -> runFrame $ DMap.singleton eResultTrigger x)
150+ maybe (return ()) runAction mAction
151+ return (eResult, runAction)
152+ eSetup <- performEvent . fmap (setup . (^?here)) . align eAction =<< getEInit
153+ dRunAction <- holdDyn Nothing $ fmap (Just . snd) eSetup
154+ 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
155+ switchPromptly never (fmap fst eSetup)
156+
157+data TextInput t
158+ = TextInput { _textInput_value :: Dynamic t String
159+ , _textInput_keypress :: Event t Int
160+ , _textInput_keydown :: Event t Int
161+ , _textInput_keyup :: Event t Int
162+ , _textInput_hasFocus :: Dynamic t Bool
163+ , _textInput_element :: Dynamic t (Maybe HTMLInputElement)
164+ }
165+
166+textInputGetEnter :: Reflex t => TextInput t -> Event t ()
167+textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i
168+
169+setElementAttributes :: IsElement self => self -> Map String String -> IO ()
170+setElementAttributes e attrs = do
171+ oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
172+ forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet attrs) $ elementRemoveAttribute e
173+ iforM_ attrs $ elementSetAttribute e
174+
175+wrapDomEvent :: (HasRunFrame t h, MonadIO m, MonadReflexHost t h, MonadIO h) => e -> (e -> m () -> IO (IO ())) -> m a -> h (Event t a)
176+wrapDomEvent self elementOnevent getValue = do
177+ runFrame <- askRunFrame
178+ e <- newEventWithTrigger $ \et -> do
179+ unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent self $ {-# SCC "c" #-} do
180+ v <- {-# SCC "d" #-} getValue
181+ liftIO $ runFrame $ DMap.singleton et v
182+ return $ liftIO $ do
183+ {-# SCC "e" #-} unsubscribe
184+ return $! {-# SCC "f" #-} e
185+
186+{-# INLINABLE input #-}
187+input' :: MonadWidget t h m => String -> Event t String -> Dynamic t (Map String String) -> m (TextInput t)
188+input' inputType eSetValue dAttrs = do
189+ dEffectiveAttrs <- mapDyn (Map.insert "type" inputType) dAttrs
190+ let mkSelf (initialValue, initialAttrs) = do
191+ doc <- askDocument
192+ Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
193+ liftIO $ htmlInputElementSetValue e initialValue
194+ iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
195+ eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e
196+ runFrame <- askRunFrame
197+ eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
198+ unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
199+ runFrame $ DMap.singleton eChangeFocusTrigger False
200+ unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
201+ runFrame $ DMap.singleton eChangeFocusTrigger True
202+ return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
203+ eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
204+ eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event
205+ eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event
206+ return (e, eChange, eKeypress, eKeydown, eKeyup, eChangeFocus)
207+ dInitialValue <- holdDyn "" eSetValue
208+ dInitial <- combineDyn (,) dInitialValue dEffectiveAttrs
209+ eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
210+ dMyElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
211+ performEvent_ . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dEffectiveAttrs
212+ putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated
213+ performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlInputElementSetValue e v) $ attachWith (\e v -> case e of
214+ Nothing -> Nothing
215+ Just e' -> Just (e',v)) (current dMyElement) eSetValue
216+ eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
217+ 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
218+ dValue <- holdDyn "" $ leftmost [eSetValue, eChange]
219+ eKeypress <- liftM switch $ hold never $ fmap (^. _3) eCreated
220+ eKeydown <- liftM switch $ hold never $ fmap (^. _4) eCreated
221+ eKeyup <- liftM switch $ hold never $ fmap (^. _5) eCreated
222+ return $ TextInput dValue eKeypress eKeydown eKeyup dFocus dMyElement
223+
224+input :: MonadWidget t h m => String -> Map String String -> m (TextInput t)
225+input t as = input' t never (constDyn as)
226+
227+data TextArea t
228+ = TextArea { _textArea_value :: Dynamic t String
229+ , _textArea_element :: Dynamic t (Maybe HTMLTextAreaElement)
230+ }
231+
232+textArea' :: MonadWidget t h m => Event t String -> Dynamic t (Map String String) -> m (TextArea t)
233+textArea' eSetValue dAttrs = do
234+ let mkSelf (initialValue, initialAttrs) = do
235+ doc <- askDocument
236+ Just e <- liftIO $ liftM (fmap castToHTMLTextAreaElement) $ documentCreateElement doc "textarea"
237+ liftIO $ htmlTextAreaElementSetValue e initialValue
238+ iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
239+ eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e
240+ return (e, eChange)
241+ dInitialValue <- holdDyn "" eSetValue
242+ dInitial <- combineDyn (,) dInitialValue dAttrs
243+ eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
244+ dMyElement <- holdDyn Nothing $ fmap (Just . fst) eCreated
245+ --performEvent . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dAttrs
246+ putEChildren $ fmap ((:[]) . toNode . fst) eCreated
247+ performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlTextAreaElementSetValue e v) $ attachWith (\e v -> case e of
248+ Nothing -> Nothing
249+ Just e' -> Just (e',v)) (current dMyElement) eSetValue
250+ eChange <- liftM switch $ hold never $ fmap snd eCreated
251+ dValue <- holdDyn "" $ leftmost [eSetValue, eChange]
252+ return $ TextArea dValue dMyElement
253+
254+
255+data Checkbox t
256+ = Checkbox { _checkbox_checked :: Dynamic t Bool
257+ }
258+
259+checkbox :: MonadWidget t h m => Bool -> Map String String -> m (Checkbox t)
260+checkbox checked attrs = do
261+ let mkSelf = do
262+ doc <- askDocument
263+ Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
264+ liftIO $ elementSetAttribute e "type" "checkbox"
265+ iforM_ attrs $ \attr value -> liftIO $ elementSetAttribute e attr value
266+ if checked == True then liftIO $ elementSetAttribute e "checked" "true" else return ()
267+ eChange <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e
268+ return ([toNode e], eChange)
269+ eCreated <- performEvent . fmap (const mkSelf) =<< getEInit
270+ putEChildren $ fmap (^. _1) eCreated
271+ eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
272+ dValue <- holdDyn checked eChange
273+ return $ Checkbox dValue
274+
275+checkboxView :: MonadWidget t h m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t ())
276+checkboxView dAttrs dValue = do
277+ dEffectiveAttrs <- mapDyn (Map.insert "type" "checkbox") dAttrs
278+ let mkSelf (initialValue, initialAttrs) = do
279+ doc <- askDocument
280+ Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
281+ iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
282+ liftIO $ htmlInputElementSetChecked e initialValue
283+ eClicked <- wrapDomEvent e elementOnclick preventDefault
284+ return (e, eClicked)
285+ dInitial <- combineDyn (,) dValue dEffectiveAttrs
286+ eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
287+ putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated
288+ dElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
289+ performEvent_ . updated =<< combineDyn (\me a -> forM_ me $ \e -> liftIO $ setElementAttributes e a) dElement dEffectiveAttrs
290+ performEvent_ . updated =<< combineDyn (\v me -> maybe (return ()) (\e -> liftIO $ htmlInputElementSetChecked e v) me) dValue dElement
291+ liftM switch $ hold never $ fmap (^. _2) eCreated
292+
293+{-# INLINABLE textInput #-}
294+textInput :: MonadWidget t h m => m (TextInput t)
295+textInput = input "text" $ Map.singleton "class" "form-control"
296+
297+data Dropdown t k
298+ = Dropdown { _dropdown_value :: Dynamic t k
299+ }
300+
301+setInnerText :: (HasDocument m, IsHTMLElement self, MonadIO m) => self -> String -> m (Maybe Node)
302+setInnerText e s = do
303+ liftIO $ htmlElementSetInnerHTML e ""
304+ doc <- askDocument
305+ t <- liftIO $ documentCreateTextNode doc s
306+ liftIO $ nodeAppendChild e t
307+
308+--TODO: Retain set value when allowed values changes
309+{-# INLINABLE dropdown #-}
310+dropdown :: forall t h m k. (MonadWidget t h m, Show k, Read k) => Dynamic t (Map k String) -> m (Dropdown t (Maybe k))
311+dropdown dOptions = do
312+ let triggerChange (e, reChangeTrigger) runFrame = do
313+ v <- htmlSelectElementGetValue e
314+ readRef reChangeTrigger >>= mapM_ (\eChangeTrigger -> runFrame $ DMap.singleton eChangeTrigger $ readMay v)
315+ let mkSelf = do
316+ doc <- askDocument
317+ Just e <- liftIO $ liftM (fmap castToHTMLSelectElement) $ documentCreateElement doc "select"
318+ liftIO $ elementSetAttribute e "class" "form-control"
319+ runFrame <- askRunFrame
320+ reChangeTrigger <- newRef Nothing
321+ eChange <- newEventWithTrigger $ \eChangeTrigger -> do
322+ writeRef reChangeTrigger $ Just eChangeTrigger
323+ unsubscribe <- liftIO $ elementOnchange e $ liftIO $ triggerChange (e, reChangeTrigger) runFrame
324+ return $ do
325+ writeRef reChangeTrigger Nothing
326+ liftIO unsubscribe
327+ return ((e, reChangeTrigger), eChange)
328+ eCreated <- performEvent . fmap (const mkSelf) =<< getEInit
329+ dState <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
330+ putEChildren $ fmap ((:[]) . toNode . fst . (^. _1)) eCreated
331+ let updateOptions :: Map k String -> Maybe (HTMLSelectElement, Ref h (Maybe (EventTrigger t (Maybe k)))) -> h ()
332+ updateOptions options = maybe (return ()) $ \myState@(selectElement, _) -> do
333+ doc <- askDocument
334+ liftIO $ htmlElementSetInnerHTML selectElement ""
335+ iforM_ options $ \k optionText -> do
336+ Just optionElement <- liftIO $ liftM (fmap castToHTMLOptionElement) $ documentCreateElement doc "option"
337+ liftIO $ elementSetAttribute optionElement "value" $ show k
338+ _ <- setInnerText optionElement optionText
339+ liftIO $ nodeAppendChild selectElement $ Just optionElement
340+ runFrame <- askRunFrame
341+ liftIO $ triggerChange myState runFrame
342+ performEvent_ . updated =<< combineDyn updateOptions dOptions dState
343+ eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
344+ dValue <- holdDyn Nothing eChange
345+ return $ Dropdown dValue
346+
347+data Link t
348+ = Link { _link_clicked :: Event t ()
349+ }
350+
351+linkClassWithExtraSetup :: MonadWidget t h m => (HTMLElement -> h ()) -> String -> String -> m (Link t)
352+linkClassWithExtraSetup extraSetup s c = do
353+ let mkSelf = do
354+ doc <- askDocument
355+ Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "a"
356+ _ <- setInnerText e s
357+ liftIO $ elementSetAttribute e "class" c
358+ eClicked <- wrapDomEvent e elementOnclick $ return ()
359+ extraSetup e
360+ return ([toNode e], eClicked)
361+ eCreated <- performEvent . fmap (const mkSelf) =<< getEInit
362+ putEChildren $ fmap (^. _1) eCreated
363+ eClicked <- liftM switch $ hold never $ fmap (^. _2) eCreated
364+ return $ Link eClicked
365+
366+{-# INLINABLE linkClass #-}
367+linkClass :: MonadWidget t h m => String -> String -> m (Link t)
368+linkClass = linkClassWithExtraSetup $ const $ return ()
369+
370+{-# INLINABLE link #-}
371+link :: MonadWidget t h m => String -> m (Link t)
372+link s = linkClass s ""
373+
374+{-# INLINABLE button #-}
375+button :: MonadWidget t h m => String -> m (Link t)
376+button s = linkClass s "btn btn-primary"
377+
378+{-# INLINABLE elAttr #-}
379+elAttr :: forall t h m a. MonadWidget t h m => String -> Map String String -> m a -> m a
380+elAttr elementTag attrs child = liftM snd $ elAttr' elementTag attrs child
381+
382+{-# INLINABLE el' #-}
383+el' :: forall t h m a. MonadWidget t h m => String -> m a -> m (El t, a)
384+el' elementTag child = elAttr' elementTag Map.empty child
385+
386+{-# INLINABLE elAttr' #-}
387+elAttr' :: forall t h m a. MonadWidget t h m => String -> Map String String -> m a -> m (El t, a)
388+elAttr' elementTag attrs child = do
389+ dAttributes <- holdDyn attrs never
390+ elDynAttr' elementTag dAttributes child
391+
392+{-# INLINABLE elDynAttr #-}
393+elDynAttr :: forall t h m a. MonadWidget t h m => String -> Dynamic t (Map String String) -> m a -> m a
394+elDynAttr elementTag dAttributes child = liftM snd $ elDynAttr' elementTag dAttributes child
395+
396+{-# INLINABLE el #-}
397+el :: forall t h m a. MonadWidget t h m => String -> m a -> m a
398+el elementTag child = elAttr elementTag Map.empty child
399+
400+newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
401+
402+workflowView :: forall t h m a. MonadWidget t h m => Workflow t (WidgetEventM m) a -> m (Event t a)
403+workflowView w0 = do
404+ rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
405+ eReplace <- liftM switch $ hold never $ fmap snd eResult
406+ eResult `seq` eReplace `seq` return ()
407+ return $ fmap fst eResult
408+
409+insertNext :: (Ord k, Enum k) => v -> Map k v -> Map k v
410+insertNext v m =
411+ let k = case Map.maxViewWithKey m of
412+ Nothing -> toEnum 0
413+ Just ((k0, _), _) -> succ k0
414+ in Map.insert k v m
415+
416+{-# INLINABLE oldList #-}
417+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 ()))
418+oldList dm = el "ul" $ list dm (\dv -> el "li" (dyn dv) >> return ())
419+
420+{-# INLINABLE list #-}
421+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'))
422+list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
423+
424+instance MonadWidget' t h m => MonadWidget' t h (ReaderT r m) where
425+ type WidgetEventM (ReaderT r m) = ReaderT r (WidgetEventM m)
426+ elDynAttr' tag dAttrs = mapReaderT (elDynAttr' tag dAttrs)
427+ performEvent = lift . performEvent
428+ performEvent_ = lift . performEvent_
429+ getEInit = lift getEInit
430+ putEChildren = lift . putEChildren
431+ dyn d = do
432+ r <- ask
433+ lift $ dyn =<< mapDyn (flip runReaderT r) d
434+ listWithKey d w = do
435+ r <- ask
436+ lift $ listWithKey d $ \k dv -> runReaderT (w k dv) r
437+ text = lift . text
438+ dynText = lift . dynText
439+
440+-}
src/Reflex/Dom/Internal.hsnew file+205
@@ -0,0 +1,205 @@
1+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, ConstraintKinds #-}
2+module Reflex.Dom.Internal where
3+
4+import Prelude hiding (mapM, mapM_, concat, sequence, sequence_)
5+
6+import Reflex.Dom.Class
7+
8+import GHCJS.DOM
9+import GHCJS.DOM.Types hiding (Widget, unWidget, Event)
10+import GHCJS.DOM.Node
11+import GHCJS.DOM.Element
12+import GHCJS.DOM.HTMLElement
13+import GHCJS.DOM.HTMLInputElement
14+import GHCJS.DOM.NamedNodeMap
15+import GHCJS.DOM.Document
16+import GHCJS.DOM.UIEvent
17+import GHCJS.DOM.EventM (event, Signal (..))
18+import Reflex.Class
19+import Reflex.Dynamic
20+import Reflex.Host.Class
21+import Reflex.Spider (Spider, SpiderHost (..))
22+import qualified Reflex.Spider
23+import Control.Lens
24+import Control.Applicative
25+import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
26+import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
27+import Control.Monad.Ref
28+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
29+import Data.Map (Map)
30+import qualified Data.Map as Map
31+import Data.Set (Set)
32+import qualified Data.Set as Set
33+import Control.Concurrent
34+import Data.Dependent.Sum (DSum (..))
35+import Data.Dependent.Map (DMap)
36+import qualified Data.Dependent.Map as DMap
37+import Data.Foldable
38+import Data.Traversable
39+import Data.IORef
40+import Data.Align
41+import Data.These
42+import Data.ByteString (ByteString)
43+import qualified Data.Text as T
44+import Data.Text.Encoding
45+import Data.Monoid ((<>))
46+
47+import System.IO.Unsafe
48+
49+data GuiEnv t h
50+ = GuiEnv { _guiEnvDocument :: !HTMLDocument
51+ , _guiEnvPostGui :: !(h () -> IO ())
52+ , _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())
53+ }
54+
55+--TODO: Poorly named
56+newtype Gui t h m a = Gui { unGui :: ReaderT (GuiEnv t h) m a } deriving (Functor, Monad, MonadIO, MonadFix)
57+
58+runGui :: Gui t h m a -> GuiEnv t h -> m a
59+runGui (Gui g) env = runReaderT g env
60+
61+instance MonadTrans (Gui t h) where
62+ lift = Gui . lift
63+
64+instance MonadRef m => MonadRef (Gui t h m) where
65+ type Ref (Gui t h m) = Ref m
66+ newRef = lift . newRef
67+ readRef = lift . readRef
68+ writeRef r = lift . writeRef r
69+ atomicModifyRef r f = lift $ atomicModifyRef r f
70+
71+instance MonadSample t m => MonadSample t (Gui t h m) where
72+ sample b = lift $ sample b
73+
74+instance MonadHold t m => MonadHold t (Gui t h m) where
75+ hold a0 e = lift $ hold a0 e
76+
77+instance (Reflex t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (Gui t h m) where
78+ newEventWithTrigger initializer = lift $ newEventWithTrigger initializer
79+
80+data WidgetEnv
81+ = WidgetEnv { _widgetEnvParent :: !Node
82+ }
83+
84+data WidgetState t m
85+ = WidgetState { _widgetStatePostBuild :: !(m ())
86+ , _widgetStateVoidActions :: ![Event t (m ())] --TODO: Would it help to make this a strict list?
87+ }
88+
89+liftM concat $ mapM makeLenses
90+ [ ''WidgetEnv
91+ , ''WidgetState
92+ , ''GuiEnv
93+ ]
94+
95+instance Monad m => HasDocument (Gui t h m) where
96+ askDocument = Gui $ view guiEnvDocument
97+
98+instance HasDocument m => HasDocument (Widget t m) where
99+ askDocument = lift askDocument
100+
101+instance (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h (Gui t h m) where
102+ askPostGui = Gui $ view guiEnvPostGui
103+ askRunWithActions = Gui $ view guiEnvRunWithActions
104+
105+instance HasPostGui t h m => HasPostGui t h (Widget t m) where
106+ askPostGui = lift askPostGui
107+ askRunWithActions = lift askRunWithActions
108+
109+type WidgetInternal t m a = ReaderT WidgetEnv (StateT (WidgetState t m) m) a
110+
111+instance MonadTrans (Widget t) where
112+ lift = Widget . lift . lift
113+
114+newtype Widget t m a = Widget { unWidget :: WidgetInternal t m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
115+
116+instance MonadSample t m => MonadSample t (Widget t m) where
117+ sample b = lift $ sample b
118+
119+instance MonadHold t m => MonadHold t (Widget t m) where
120+ hold v0 e = lift $ hold v0 e
121+
122+-- Need to build FRP circuit first, then elements
123+ -- Can't read from FRP until the whole thing is built
124+--TODO: Use JSString when in JS
125+
126+instance MonadRef m => MonadRef (Widget t m) where
127+ type Ref (Widget t m) = Ref m
128+ newRef = lift . newRef
129+ readRef = lift . readRef
130+ writeRef r = lift . writeRef r
131+ atomicModifyRef r f = lift $ atomicModifyRef r f
132+
133+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Widget t m) where
134+ newEventWithTrigger = lift . newEventWithTrigger
135+
136+instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Shouldn't need to be IO
137+ , MonadIO m, Functor m
138+ , ReflexHost t, MonadReflexCreateTrigger t m, MonadSample t m, MonadHold t m
139+ , MonadFix m
140+ ) => MonadWidget t (Widget t (Gui t h m)) where
141+ type WidgetHost (Widget t (Gui t h m)) = Gui t h m
142+ type GuiAction (Widget t (Gui t h m)) = h
143+ askParent = Widget $ view widgetEnvParent
144+ --TODO: Use types to separate cohorts of possibly-recursive events/behaviors
145+ -- | Schedule an action to occur after the current cohort has been built; this is necessary because Behaviors built in the current cohort may not be read until after it is complete
146+ --schedulePostBuild :: Monad m => m () -> WidgetInternal t m ()
147+ schedulePostBuild a = Widget $ widgetStatePostBuild %= (a>>) --TODO: Can this >> be made strict?
148+
149+ --addVoidAction :: Monad m => Event t (m ()) -> WidgetInternal t m ()
150+ addVoidAction a = Widget $ widgetStateVoidActions %= (a:)
151+ subWidget n child = Widget $ local (widgetEnvParent .~ toNode n) $ unWidget child
152+-- runWidget :: (Monad m, IsNode n, Reflex t) => n -> Widget t m a -> m (a, Event t (m ()))
153+ getRunWidget = return runWidget
154+
155+runWidget rootElement w = do
156+ (result, WidgetState postBuild voidActions) <- runStateT (runReaderT (unWidget w) (WidgetEnv $ toNode rootElement)) (WidgetState (return ()) [])
157+ let voidAction = mergeWith (>>) voidActions
158+ postBuild --TODO: This should be run some other way; it seems to cause strictness problems when recursion crosses parent/child boundaries
159+ return (result, voidAction)
160+
161+holdOnStartup :: MonadWidget t m => a -> WidgetHost m a -> m (Behavior t a)
162+holdOnStartup a0 ma = do
163+ (startupDone, startupDoneTriggerRef) <- newEventWithTriggerRef
164+ schedulePostBuild $ do
165+ a <- ma
166+ runFrameWithTriggerRef startupDoneTriggerRef a
167+ hold a0 startupDone
168+
169+mainWidget :: Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO ()
170+mainWidget w = runWebGUI $ \webView -> do
171+ Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
172+ Just body <- documentGetBody doc
173+ attachWidget body w
174+
175+mainWidgetWithCss css w = runWebGUI $ \webView -> do
176+ Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
177+ Just head <- liftM (fmap castToHTMLElement) $ documentGetHead doc
178+ htmlElementSetInnerHTML head $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
179+ Just body <- documentGetBody doc
180+ attachWidget body w
181+
182+attachWidget :: (IsHTMLElement e) => e -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) a -> IO a
183+attachWidget rootElement w = runSpiderHost $ do --TODO: It seems to re-run this handler if the URL changes, even if it's only the fragment
184+ Just doc <- liftM (fmap castToHTMLDocument) $ liftIO $ nodeGetOwnerDocument rootElement
185+ liftIO $ putStrLn "Using Widget2"
186+ frames <- liftIO newChan
187+ rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost) runWithActions :: GuiEnv Spider SpiderHost
188+ runWithActions dm = do
189+ voidActionNeeded <- fireEventsAndRead dm $ do
190+ sequence =<< readEvent voidAction
191+ runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv
192+ Just df <- liftIO $ documentCreateDocumentFragment doc
193+ (result, voidAction) <- runHostFrame $ runGui (runWidget df w) guiEnv
194+ liftIO $ htmlElementSetInnerHTML rootElement ""
195+ liftIO $ nodeAppendChild rootElement $ Just df
196+ subscribeEvent voidAction --TODO: Should be unnecessary
197+-- currentFrame <- liftIO $ newEmptyMVar
198+-- idleAdd (tryTakeMVar currentFrame >>= maybe (return ()) id >> return True) priorityLow --TODO: avoid wasting CPU here
199+-- forkIO $ forever $ putMVar currentFrame =<< readChan frames
200+ --postGUISync seems to leak memory on GHC (unknown on GHCJS)
201+ liftIO $ forkIO $ forever $ postGUISync =<< readChan frames -- postGUISync is necessary to prevent segfaults in GTK, which is not thread-safe
202+ return result
203+
204+--type MonadWidget t h m = (t ~ Spider, h ~ Gui Spider SpiderHost (HostFrame Spider), m ~ Widget t h, Monad h, MonadHold t h, HasDocument h, MonadSample t h, MonadRef h, MonadIO h, Functor (Event t), Functor h, Reflex t) -- Locking down these types seems to help a little in GHCJS, but not really in GHC
205+
src/Reflex/Dom/Widget.hsnew file+6
@@ -0,0 +1,6 @@
1+module Reflex.Dom.Widget ( module Reflex.Dom.Widget.Basic
2+ , module Reflex.Dom.Widget.Input
3+ ) where
4+
5+import Reflex.Dom.Widget.Basic
6+import Reflex.Dom.Widget.Input
src/Reflex/Dom/Widget/Basic.hsnew file+375
@@ -0,0 +1,375 @@
1+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo #-}
2+
3+module Reflex.Dom.Widget.Basic where
4+
5+import Reflex.Dom.Class
6+
7+import Reflex
8+import Reflex.Host.Class
9+import Data.Map (Map)
10+import qualified Data.Map as Map
11+import Data.Set (Set)
12+import qualified Data.Set as Set
13+import Data.Dependent.Sum (DSum (..))
14+import Control.Monad.Trans
15+import Control.Monad.Reader
16+import Control.Monad.Ref
17+import GHCJS.DOM.Node
18+import GHCJS.DOM.UIEvent
19+import GHCJS.DOM.EventM (event, Signal)
20+import GHCJS.DOM.Document
21+import GHCJS.DOM.Element
22+import GHCJS.DOM.HTMLElement
23+import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)
24+import GHCJS.DOM.NamedNodeMap
25+import Control.Lens
26+import Data.Monoid
27+import Data.These
28+import Data.Align
29+
30+import Data.Maybe
31+
32+type AttributeMap = Map String String
33+
34+data El t
35+ = El { _el_element :: HTMLElement
36+ , _el_clicked :: Event t ()
37+ , _el_keypress :: Event t Int
38+ }
39+
40+class Attributes m a where
41+ addAttributes :: IsElement e => a -> e -> m ()
42+
43+instance MonadIO m => Attributes m AttributeMap where
44+ addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs
45+
46+instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
47+ addAttributes attrs e = do
48+ schedulePostBuild $ do
49+ curAttrs <- sample $ current attrs
50+ liftIO $ imapM_ (elementSetAttribute e) curAttrs
51+ addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do
52+ oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
53+ forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
54+ imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
55+
56+buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement
57+buildEmptyElement elementTag attrs = do
58+ doc <- askDocument
59+ p <- askParent
60+ Just e <- liftIO $ documentCreateElement doc elementTag
61+ addAttributes attrs e
62+ _ <- liftIO $ nodeAppendChild p $ Just e
63+ return $ castToHTMLElement e
64+
65+-- 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
66+buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)
67+buildElement elementTag attrs child = do
68+ e <- buildEmptyElement elementTag attrs
69+ result <- subWidget (toNode e) child
70+ return (e, result)
71+
72+namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
73+namedNodeMapGetNames self = do
74+ l <- namedNodeMapGetLength self
75+ 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
76+ liftM Set.fromList $ forM locations $ \i -> do
77+ Just n <- namedNodeMapItem self i
78+ nodeGetNodeName n
79+
80+text :: MonadWidget t m => String -> m ()
81+text = void . text'
82+
83+--TODO: Wrap the result
84+text' :: MonadWidget t m => String -> m Text
85+text' s = do
86+ doc <- askDocument
87+ p <- askParent
88+ Just n <- liftIO $ documentCreateTextNode doc s
89+ _ <- liftIO $ nodeAppendChild p $ Just n
90+ return n
91+
92+dynText :: MonadWidget t m => Dynamic t String -> m ()
93+dynText s = do
94+ n <- text' ""
95+ schedulePostBuild $ do
96+ curS <- sample $ current s
97+ liftIO $ nodeSetNodeValue n curS
98+ addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s
99+
100+--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
101+dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
102+dyn child = do
103+ startPlaceholder <- text' ""
104+ endPlaceholder <- text' ""
105+ (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
106+ let e = fmap snd newChildBuilt --TODO: Get rid of this hack
107+ childVoidAction <- hold never e
108+ performEvent_ $ fmap (const $ return ()) e --TODO: Get rid of this hack
109+ addVoidAction $ switch childVoidAction
110+ doc <- askDocument
111+ runWidget <- getRunWidget
112+ let build c = do
113+ Just df <- liftIO $ documentCreateDocumentFragment doc
114+ result <- runWidget df c
115+ runFrameWithTriggerRef newChildBuiltTriggerRef result
116+ Just p <- liftIO $ nodeGetParentNode endPlaceholder
117+ liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
118+ return ()
119+ schedulePostBuild $ do
120+ c <- sample $ current child
121+ build c
122+ addVoidAction $ ffor (updated child) $ \newChild -> do
123+ liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
124+ build newChild
125+ return $ fmap fst newChildBuilt
126+
127+widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
128+widgetHold child0 newChild = do
129+ startPlaceholder <- text' ""
130+ result0 <- child0
131+ endPlaceholder <- text' ""
132+ (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
133+ childVoidAction <- hold never $ fmap snd newChildBuilt
134+ addVoidAction $ switch childVoidAction
135+ doc <- askDocument
136+ runWidget <- getRunWidget
137+ let build c = do
138+ Just df <- liftIO $ documentCreateDocumentFragment doc
139+ result <- runWidget df c
140+ runFrameWithTriggerRef newChildBuiltTriggerRef result
141+ Just p <- liftIO $ nodeGetParentNode endPlaceholder
142+ liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
143+ return ()
144+ addVoidAction $ ffor newChild $ \c -> do
145+ liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
146+ build c
147+ holdDyn result0 $ fmap fst newChildBuilt
148+
149+--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
150+listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
151+listWithKey vals mkChild = do
152+ doc <- askDocument
153+ startPlaceholder <- text' ""
154+ endPlaceholder <- text' ""
155+ (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
156+ performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
157+ children <- hold Map.empty $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren
158+ addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
159+ runWidget <- getRunWidget
160+ let buildChild df k v = runWidget df $ do
161+ childStart <- text' ""
162+ result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
163+ childEnd <- text' ""
164+ return (result, (childStart, childEnd))
165+ schedulePostBuild $ do
166+ Just df <- liftIO $ documentCreateDocumentFragment doc
167+ curVals <- sample $ current vals
168+ initialState <- iforM curVals $ buildChild df
169+ runFrameWithTriggerRef newChildrenTriggerRef initialState --TODO: Do all these in a single runFrame
170+ Just p <- liftIO $ nodeGetParentNode endPlaceholder
171+ liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
172+ return ()
173+ addVoidAction $ flip fmap (updated vals) $ \newVals -> do
174+ curState <- sample children
175+ --TODO: Should we remove the parent from the DOM first to avoid reflows?
176+ newState <- liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
177+ This ((_, (start, end)), _) -> do
178+ liftIO $ putStrLn "Deleting item"
179+ liftIO $ deleteBetweenInclusive start end
180+ return Nothing
181+ That v -> do
182+ liftIO $ putStrLn "Creating item"
183+ Just df <- liftIO $ documentCreateDocumentFragment doc
184+ s <- buildChild df k v
185+ let placeholder = case Map.lookupGT k curState of
186+ Nothing -> endPlaceholder
187+ Just (_, ((_, (start, _)), _)) -> start
188+ Just p <- liftIO $ nodeGetParentNode placeholder
189+ liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
190+ return $ Just s
191+ These state _ -> do
192+ liftIO $ putStrLn "Leaving item unchanged"
193+ return $ Just state
194+ liftIO $ putStrLn "Triggering newChildren"
195+ liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef
196+ runFrameWithTriggerRef newChildrenTriggerRef newState
197+ liftIO $ putStrLn "Triggering newChildren done"
198+ holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren
199+
200+selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k) => Dynamic t k -> Dynamic t (Map k v) -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -> m (Event t k)
201+selectViewListWithKey_ selection vals mkChild = do
202+ let selectionDemux = demux selection -- For good performance, this value must be shared across all children
203+ selectChild <- listWithKey vals $ \k v -> do
204+ selected <- getDemuxed selectionDemux k
205+ selectSelf <- mkChild k v selected
206+ return $ fmap (const k) selectSelf
207+ liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
208+
209+--------------------------------------------------------------------------------
210+-- Basic DOM manipulation helpers
211+--------------------------------------------------------------------------------
212+
213+-- | s and e must both be children of the same node and s must precede e
214+deleteBetweenExclusive s e = do
215+ 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
216+ let go = do
217+ Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
218+ when (unNode (toNode s) /= unNode (toNode x)) $ do
219+ nodeRemoveChild currentParent $ Just x
220+ go
221+ go
222+
223+-- | s and e must both be children of the same node and s must precede e
224+deleteBetweenInclusive s e = do
225+ 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
226+ let go = do
227+ Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
228+ nodeRemoveChild currentParent $ Just x
229+ when (unNode (toNode s) /= unNode (toNode x)) go
230+ go
231+ nodeRemoveChild currentParent $ Just e
232+
233+--------------------------------------------------------------------------------
234+-- Adapters
235+--------------------------------------------------------------------------------
236+
237+--TODO: Get rid of extra version of this function
238+wrapDomEvent element elementOnevent getValue = do
239+ postGui <- askPostGui
240+ runWithActions <- askRunWithActions
241+ e <- newEventWithTrigger $ \et -> do
242+ unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
243+ v <- {-# SCC "d" #-} getValue
244+ liftIO $ postGui $ runWithActions [et :=> v]
245+ return $ liftIO $ do
246+ {-# SCC "e" #-} unsubscribe
247+ return $! {-# SCC "f" #-} e
248+
249+wrapElement :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
250+wrapElement e = do
251+ clicked <- wrapDomEvent e elementOnclick (return ())
252+ keypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
253+ return $ El e clicked keypress
254+
255+elDynAttr' elementTag attrs child = do
256+ (e, result) <- buildElement elementTag attrs child
257+ e' <- wrapElement e
258+ return (e', result)
259+
260+{-# INLINABLE elAttr #-}
261+elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
262+elAttr elementTag attrs child = do
263+ (_, result) <- buildElement elementTag attrs child
264+ return result
265+
266+{-# INLINABLE el' #-}
267+--el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
268+el' tag child = elAttr' tag (Map.empty :: AttributeMap) child
269+
270+{-# INLINABLE elAttr' #-}
271+--elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
272+elAttr' elementTag attrs child = do
273+ (e, result) <- buildElement elementTag attrs child
274+ e' <- wrapElement e
275+ return (e', result)
276+
277+{-# INLINABLE elDynAttr #-}
278+elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
279+elDynAttr elementTag attrs child = do
280+ (_, result) <- buildElement elementTag attrs child
281+ return result
282+
283+{-# INLINABLE el #-}
284+el :: forall t m a. MonadWidget t m => String -> m a -> m a
285+el tag child = elAttr tag Map.empty child
286+
287+--------------------------------------------------------------------------------
288+-- Copied and pasted from Reflex.Widget.Class
289+--------------------------------------------------------------------------------
290+
291+list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
292+
293+{-
294+
295+--TODO: Update dynamically
296+{-# INLINABLE dynHtml #-}
297+dynHtml :: MonadWidget t m => Dynamic t String -> m ()
298+dynHtml ds = do
299+ let mkSelf h = do
300+ doc <- askDocument
301+ Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "div"
302+ liftIO $ htmlElementSetInnerHTML e h
303+ return e
304+ eCreated <- performEvent . fmap mkSelf . tagDyn ds =<< getEInit
305+ putEChildren $ fmap ((:[]) . toNode) eCreated
306+
307+-}
308+
309+data Link t
310+ = Link { _link_clicked :: Event t ()
311+ }
312+
313+linkClass :: MonadWidget t m => String -> String -> m (Link t)
314+linkClass s c = do
315+ (l,_) <- elAttr' "a" ("class" =: c) $ text s
316+ return $ Link $ _el_clicked l
317+
318+link :: MonadWidget t m => String -> m (Link t)
319+link s = linkClass s ""
320+
321+newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
322+
323+workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
324+workflowView w0 = do
325+ rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
326+ eReplace <- liftM switch $ hold never $ fmap snd eResult
327+ eResult `seq` eReplace `seq` return ()
328+ return $ fmap fst eResult
329+
330+divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
331+divClass = elAttr "div" . Map.singleton "class"
332+
333+dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
334+dtdd h w = do
335+ el "dt" $ text h
336+ el "dd" $ w
337+
338+blank :: forall t m. MonadWidget t m => m ()
339+blank = return ()
340+
341+tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k) => String -> [(String, k -> Dynamic t r -> m v)] -> Dynamic t (Map k r) -> (k -> m (Dynamic t (Map String String))) -> m (Dynamic t (Map k (El t, [v])))
342+tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
343+ elAttr "table" (Map.singleton "class" klass) $ do
344+ el "thead" $ el "tr" $ do
345+ mapM (\(h, _) -> el "th" $ text h) cols
346+ el "tbody" $ do
347+ listWithKey dRows (\k r -> do
348+ dAttrs <- rowAttrs k
349+ elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
350+
351+--TODO preselect a tab on open
352+tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
353+tabDisplay ulClass activeClass tabItems = do
354+ rec dCurrentTab <- holdDyn Nothing (updated dTabClicks)
355+ dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do
356+ tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< mapDyn (== (Just k)) dCurrentTab) tabItems
357+ let eTabClicks :: Event t k = leftmost tabClicksList
358+ holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))
359+ divClass "" $ do
360+ let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems
361+ listWithKey dTabs (\k dTab -> do
362+ dAttrs <- mapDyn (\sel -> do
363+ let t1 = listToMaybe $ Map.keys tabItems
364+ if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab
365+ elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
366+ return ()
367+ where
368+ headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k)
369+ headerBarLink x k dBool = do
370+ dAttributes <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) dBool
371+ elDynAttr "li" dAttributes $ do
372+ a <- link x
373+ return $ fmap (const k) (_link_clicked a)
374+
375+
src/Reflex/Dom/Widget/Input.hsnew file+254
@@ -0,0 +1,254 @@
1+{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, DataKinds, GADTs, ScopedTypeVariables, FlexibleInstances, RecursiveDo #-}
2+module Reflex.Dom.Widget.Input where
3+
4+import Prelude hiding (forM_)
5+
6+import Reflex.Dom.Class
7+import Reflex.Dom.Widget.Basic
8+
9+import Reflex
10+import Reflex.Host.Class
11+import Data.Map (Map)
12+import GHCJS.DOM.Document
13+import GHCJS.DOM.HTMLInputElement
14+import GHCJS.DOM.Node
15+import GHCJS.DOM.Element
16+import GHCJS.DOM.HTMLSelectElement
17+import GHCJS.DOM.EventM
18+import GHCJS.DOM.UIEvent
19+import Data.Monoid
20+import Data.Map as Map
21+import Control.Monad hiding (forM_)
22+import Control.Monad.IO.Class
23+import Control.Lens
24+import Data.Default
25+import Data.Maybe
26+import Safe
27+import Data.Dependent.Sum (DSum (..))
28+import Data.List.NonEmpty (NonEmpty (..))
29+import Data.Foldable
30+
31+input' :: MonadWidget t m => String -> String -> Event t String -> Dynamic t (Map String String) -> m (TextInput t)
32+input' inputType initial eSetValue dAttrs = do
33+ e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" inputType) dAttrs
34+ liftIO $ htmlInputElementSetValue e initial
35+ performEvent_ $ fmap (liftIO . htmlInputElementSetValue e) eSetValue
36+ eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e
37+ postGui <- askPostGui
38+ runWithActions <- askRunWithActions
39+ eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
40+ unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
41+ postGui $ runWithActions [eChangeFocusTrigger :=> False]
42+ unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
43+ postGui $ runWithActions [eChangeFocusTrigger :=> True]
44+ return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
45+ dFocus <- holdDyn False eChangeFocus
46+ eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
47+ eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event
48+ eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event
49+ dValue <- holdDyn initial $ leftmost [eSetValue, eChange]
50+ return $ TextInput dValue eKeypress eKeydown eKeyup dFocus e
51+
52+{-
53+ dSetValue <- holdDyn "" eSetValue
54+ dynText =<< combineDyn (\v a -> "Input placeholder: " <> show (inputType, v, a)) dSetValue dAttrs
55+ return $ TextInput (constDyn "") never never never (constDyn False) (constDyn Nothing)
56+
57+input' inputType eSetValue dAttrs = do
58+ dEffectiveAttrs <- mapDyn (Map.insert "type" inputType) dAttrs
59+ let mkSelf (initialValue, initialAttrs) = do
60+ doc <- askDocument
61+ Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
62+ liftIO $ htmlInputElementSetValue e initialValue
63+ iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
64+ eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e
65+ runFrame <- askRunFrame
66+ eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
67+ unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
68+ runFrame $ DMap.singleton eChangeFocusTrigger False
69+ unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
70+ runFrame $ DMap.singleton eChangeFocusTrigger True
71+ return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
72+ eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
73+ eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event
74+ eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event
75+ return (e, eChange, eKeypress, eKeydown, eKeyup, eChangeFocus)
76+ dInitialValue <- holdDyn "" eSetValue
77+ dInitial <- combineDyn (,) dInitialValue dEffectiveAttrs
78+ eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
79+ dMyElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
80+ performEvent_ . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dEffectiveAttrs
81+ putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated
82+ performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlInputElementSetValue e v) $ attachWith (\e v -> case e of
83+ Nothing -> Nothing
84+ Just e' -> Just (e',v)) (current dMyElement) eSetValue
85+ eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
86+ 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
87+ dValue <- holdDyn "" $ leftmost [eSetValue, eChange]
88+ eKeypress <- liftM switch $ hold never $ fmap (^. _3) eCreated
89+ eKeydown <- liftM switch $ hold never $ fmap (^. _4) eCreated
90+ eKeyup <- liftM switch $ hold never $ fmap (^. _5) eCreated
91+ return $ TextInput dValue eKeypress eKeydown eKeyup dFocus dMyElement
92+-}
93+
94+data TextInput t
95+ = TextInput { _textInput_value :: Dynamic t String
96+ , _textInput_keypress :: Event t Int
97+ , _textInput_keydown :: Event t Int
98+ , _textInput_keyup :: Event t Int
99+ , _textInput_hasFocus :: Dynamic t Bool
100+ , _textInput_element :: HTMLInputElement
101+ }
102+
103+textInput :: MonadWidget t m => m (TextInput t)
104+textInput = input' "text" "" never (constDyn $ Map.empty)
105+
106+textInputGetEnter :: Reflex t => TextInput t -> Event t ()
107+textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i
108+
109+{-
110+type family Controller sm t a where
111+ Controller Edit t a = (a, Event t a) -- Initial value and setter
112+ Controller View t a = Dynamic t a -- Value (always)
113+
114+type family Output sm t a where
115+ Output Edit t a = Dynamic t a -- Value (always)
116+ Output View t a = Event t a -- Requested changes
117+
118+data CheckboxConfig sm t
119+ = CheckboxConfig { _checkbox_input :: Controller sm t Bool
120+ , _checkbox_attributes :: Attributes
121+ }
122+
123+instance Reflex t => Default (CheckboxConfig Edit t) where
124+ def = CheckboxConfig (False, never) mempty
125+
126+data Checkbox sm t
127+ = Checkbox { _checkbox_output :: Output sm t Bool
128+ }
129+
130+data StateMode = Edit | View
131+
132+--TODO: There must be a more generic way to get this witness and allow us to case on the type-level StateMode
133+data StateModeWitness (sm :: StateMode) where
134+ EditWitness :: StateModeWitness Edit
135+ ViewWitness :: StateModeWitness View
136+
137+class HasStateModeWitness (sm :: StateMode) where
138+ stateModeWitness :: StateModeWitness sm
139+
140+instance HasStateModeWitness Edit where
141+ stateModeWitness = EditWitness
142+
143+instance HasStateModeWitness View where
144+ stateModeWitness = ViewWitness
145+-}
146+
147+data Checkbox t
148+ = Checkbox { _checkbox_value :: Dynamic t Bool
149+ }
150+
151+--TODO: Make attributes possibly dynamic
152+-- | Create an editable checkbox
153+-- Note: if the "type" or "checked" attributes are provided as attributes, they will be ignored
154+checkbox :: MonadWidget t m => Bool -> Map String String -> m (Checkbox t)
155+checkbox checked attrs = do
156+ e <- liftM castToHTMLInputElement $ buildEmptyElement "input" $ Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") attrs
157+ eChange <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e
158+ dValue <- holdDyn checked eChange
159+ return $ Checkbox dValue
160+
161+checkboxView :: MonadWidget t m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t Bool)
162+checkboxView dAttrs dValue = do
163+ e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs
164+ eClicked <- wrapDomEvent e elementOnclick $ do
165+ preventDefault
166+ liftIO $ htmlInputElementGetChecked e
167+ schedulePostBuild $ do
168+ v <- sample $ current dValue
169+ when v $ liftIO $ htmlInputElementSetChecked e True
170+ performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e v) $ updated dValue
171+ return eClicked
172+
173+checkboxWithLabel :: forall t m. MonadWidget t m => String -> m (Checkbox t)
174+checkboxWithLabel l = checkboxWithLabelAttrs l Map.empty
175+
176+checkboxWithLabelAttrs :: forall t m. MonadWidget t m => String -> Map String String -> m (Checkbox t)
177+checkboxWithLabelAttrs l attrs = elAttr "label" attrs $ do
178+ c <- checkbox False Map.empty
179+ text $ " " <> l
180+ return c
181+
182+
183+data Dropdown t k
184+ = Dropdown { _dropdown_value :: Dynamic t k
185+ }
186+
187+--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map
188+--TODO: Don't bake in any CSS classes
189+--TODO: Get rid of Show k and Read k by indexing the possible values ourselves
190+-- | Create a dropdown box
191+-- The first argument gives the initial value of the dropdown; if it is not present in the map of options provided, it will be added with an empty string as its text
192+dropdown :: forall k t m. (MonadWidget t m, Ord k, Show k, Read k) => k -> Dynamic t (Map k String) -> m (Dropdown t k)
193+dropdown k0 options = do
194+ (eRaw, _) <- elAttr' "select" ("class" =: "form-control") $ do
195+ optionsWithDefault <- mapDyn (`Map.union` (k0 =: "")) options
196+ listWithKey optionsWithDefault $ \k v -> do
197+ elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ dynText v
198+ let e = castToHTMLSelectElement $ _el_element eRaw
199+ eChange <- wrapDomEvent e elementOnchange $ do
200+ kStr <- liftIO $ htmlSelectElementGetValue e
201+ return $ readMay kStr
202+ let readKey opts mk = fromMaybe k0 $ do
203+ k <- mk
204+ guard $ Map.member k opts
205+ return k
206+ dValue <- combineDyn readKey options =<< holdDyn (Just k0) eChange
207+ return $ Dropdown dValue
208+
209+--TODO: Get rid of Show k and Read k by indexing the possible values ourselves
210+dropdown' :: forall k t m. (MonadWidget t m, Eq k, Show k, Read k) => k -> NonEmpty (k, String) -> m (Dropdown t k)
211+dropdown' k0 ks = do
212+ (eRaw, _) <- elAttr' "select" ("class" =: "form-control") $ do
213+ forM_ ks $ \(k, name) -> do
214+ elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ text name
215+ let e = castToHTMLSelectElement $ _el_element eRaw
216+ eChange <- wrapDomEvent e elementOnchange $ do
217+ kStr <- liftIO $ htmlSelectElementGetValue e
218+ return $ readMay kStr
219+ let readKey mk = fromMaybe k0 mk
220+ dValue <- mapDyn readKey =<< holdDyn (Just k0) eChange
221+ return $ Dropdown dValue
222+
223+--TODO Remove CSS Classes
224+searchInputResult :: forall t m a. MonadWidget t m => Dynamic t (String, a) -> m (Event t (String, a))
225+searchInputResult r = el "li" $ do
226+ (li, _) <- elAttr' "a" (Map.singleton "style" "cursor: pointer;") $ dynText =<< mapDyn fst r
227+ return $ tag (current r) (_el_clicked li)
228+
229+searchInput :: forall t m a k. (MonadWidget t m, Ord k) => Map k (String, a) -> Event t (Map k (String, a)) -> m (Event t String, Event t (String, a))
230+searchInput initial results = searchInput' initial results searchInputResultsList
231+
232+searchInput' :: forall t m a k. (MonadWidget t m, Ord k) => Map k (String, a) -> Event t (Map k (String, a)) -> (Dynamic t (Map k (String, a)) -> m (Event t (String, a))) -> m (Event t String, Event t (String, a))
233+searchInput' initial results listBuilder = do
234+ rec input <- input' "text" "" eSetValue $ constDyn $ Map.fromList [("class", "form-control"), ("placeholder", "Search")]
235+ dResults <- holdDyn initial $ leftmost [eClearResults, results]
236+ eMadeChoice <- listBuilder dResults
237+ let eSetValue = fmap fst eMadeChoice
238+ eSelectionMade = fmap (const Nothing) eSetValue
239+ eInputChanged = fmapMaybe id $ leftmost [eSelectionMade, fmap Just (updated $ _textInput_value input)]
240+ eInputEmpty = fmapMaybe id $ fmap (\i -> if i == "" then Just Map.empty else Nothing) eInputChanged
241+ eClearResults = leftmost [eInputEmpty, fmap (const Map.empty) eMadeChoice]
242+ return (eInputChanged, eMadeChoice)
243+
244+searchInputResultsList :: forall t m a k. (MonadWidget t m, Ord k) => Dynamic t (Map k (String, a)) -> m (Event t (String, a))
245+searchInputResultsList results = searchInputResultsList' results (flip list searchInputResult)
246+
247+searchInputResultsList' :: forall t m a k. (MonadWidget t m, Ord k) => Dynamic t (Map k (String, a)) -> (Dynamic t (Map k (String, a)) -> m (Dynamic t (Map k (Event t (String, a))))) -> m (Event t (String, a))
248+searchInputResultsList' results builder = do
249+ let hideDropdown = Map.fromList [("class", "dropdown-menu"), ("style", "display: none;")]
250+ showDropdown = Map.fromList [("class", "dropdown-menu"), ("style", "display: block;")]
251+ attrs <- mapDyn (\rs -> if Map.null rs then hideDropdown else showDropdown) results
252+ resultsList <- elDynAttr "ul" attrs $ builder results
253+ liftM switch $ hold never $ fmap (leftmost . Map.elems) (updated resultsList)
254+