@@ -0,0 +1,263 @@
1+-- Common helpers to build DOM with Reflex.
2+module Reflex.Dom.Extra where
3+
4+import Control.Lens
5+import Control.Monad.Fix
6+import Data.Either
7+import Data.Map as M
8+import Data.Maybe
9+import Data.Text as T hiding (zip, map)
10+import Language.Javascript.JSaddle
11+import Reflex.Dom
12+import JavaScript.Object.Internal as JS
13+
14+-- | @<meta>@ element.
15+meta :: DomBuilder t m => Map Text Text -> m ()
16+meta attrs = elAttr "meta" attrs blank
17+
18+-- | Stylesheet link.
19+stylesheet :: DomBuilder t m => Text -> m ()
20+stylesheet ref = elAttr "link" ("rel" =: "stylesheet" <> "href" =: ref) blank
21+
22+-- | <script> tag. Do not use in dynamic contexts, or it will be executed twice.
23+script :: DomBuilder t m => Text -> m ()
24+script url = elAttr "script" ("type" =: "text/javascript" <> "src" =: url) blank
25+
26+-- | @<main>@ element with given CSS class.
27+mainClass :: DomBuilder t m => Text -> m a -> m a
28+mainClass = elClass "main"
29+
30+-- | @<span>@ element with given CSS class.
31+spanClass :: DomBuilder t m => Text -> m a -> m a
32+spanClass = elClass "span"
33+
34+-- | @<label>@ element with given CSS class.
35+labelClass :: DomBuilder t m => Text -> m a -> m a
36+labelClass = elClass "label"
37+
38+-- | @<section>@ element with given CSS class.
39+sectionClass :: DomBuilder t m => Text -> m a -> m a
40+sectionClass = elClass "section"
41+
42+-- | @<b>@ element with given CSS class.
43+bClass :: DomBuilder t m => Text -> m a -> m a
44+bClass = elClass "b"
45+
46+-- | @<tr>@ element with given CSS class.
47+trClass :: DomBuilder t m => Text -> m a -> m a
48+trClass = elClass "tr"
49+
50+-- | @<th>@ element with given CSS class.
51+thClass :: DomBuilder t m => Text -> m a -> m a
52+thClass = elClass "th"
53+
54+-- | @<td>@ element with given CSS class.
55+tdClass :: DomBuilder t m => Text -> m a -> m a
56+tdClass = elClass "td"
57+
58+-- | Line break (@<br>@).
59+br :: DomBuilder t m => m ()
60+br = el "br" blank
61+
62+-- | Button element, returns click event.
63+button
64+ :: DomBuilder t m
65+ => Text
66+ -- ^ Label.
67+ -> Map Text Text
68+ -- ^ Attributes.
69+ -> m (Event t ())
70+button label attrs = do
71+ (e, _) <- elAttr' "button" (attrs <> "type" =: "button") $ text label
72+ return $ domEvent Click e
73+
74+-- | Button element with only "class" attribute.
75+buttonClass
76+ :: DomBuilder t m
77+ => Text
78+ -- ^ Label.
79+ -> Text
80+ -- ^ CSS class.
81+ -> m (Event t ())
82+buttonClass label cls = do
83+ (e, _) <- elAttr' "button" ("class" =: cls <> "type" =: "button") $ text label
84+ return $ domEvent Click e
85+
86+-- | Button element with dynamic attributes.
87+buttonDynAttrs
88+ :: (DomBuilder t m, PostBuild t m)
89+ => Text
90+ -- ^ Label.
91+ -> Dynamic t (Map Text Text)
92+ -- ^ Attributes.
93+ -> m (Event t ())
94+buttonDynAttrs label dynAttrs = buttonDyn (constDyn label) dynAttrs
95+
96+-- | Button element with dynamic label.
97+buttonDynLabel
98+ :: (DomBuilder t m, PostBuild t m)
99+ => Dynamic t Text
100+ -- ^ Label.
101+ -> Map Text Text
102+ -- ^ Attributes.
103+ -> m (Event t ())
104+buttonDynLabel dynLabel attrs = buttonDyn dynLabel (constDyn attrs)
105+
106+-- | Button element with dynamic label and attributes.
107+buttonDyn
108+ :: (DomBuilder t m, PostBuild t m)
109+ => Dynamic t Text
110+ -- ^ Label.
111+ -> Dynamic t (Map Text Text)
112+ -- ^ Attributes.
113+ -> m (Event t ())
114+buttonDyn dynLabel dynAttrs = do
115+ (e, _) <- elDynAttr' "button" ((<> "type" =: "button") <$> dynAttrs)
116+ $ dynText dynLabel
117+ return $ domEvent Click e
118+
119+-- | Dynamic list widget that creates a list that supports the dynamic
120+-- addition and removal of items. This widget is completely general with zero
121+-- markup-specific choices. It handles all the event plumbing and lets you
122+-- completely determine the markup.
123+dynamicList
124+ :: MonadWidget t m
125+ => (Int -> a -> Event t a -> m b)
126+ -- ^ Widget used to display each item
127+ -> (b -> Event t ())
128+ -- ^ Function that gets a remove event from the return value of each item
129+ -> Event t a
130+ -- ^ Event that adds a new item to the list that is not based on an
131+ -- existing item.
132+ -> [a]
133+ -- ^ Initial list of items
134+ -> m (Dynamic t [b])
135+dynamicList w removeEvent addEvent initList = do
136+ let initMap = M.fromList $ zip [0..] initList
137+ rec
138+ let
139+ vals = mergeWith (<>)
140+ [ attachWith addNew (current res) addEvent
141+ , remove (current res) ]
142+ res <- listWithKeyShallowDiff initMap vals w
143+ return $ M.elems <$> res
144+ where
145+ addNew m a = M.singleton k (Just a)
146+ where
147+ k = if M.null m then 0 else fst (M.findMax m) + 1
148+ remove res = switch (mergeWith (<>) . fmap f . M.toList <$> res)
149+ where
150+ f (k,b) = M.singleton k Nothing <$ removeEvent b
151+
152+-- | Build widget using text value, if any. Otherwise stays blank.
153+maybeBlank :: DomBuilder t m => Maybe Text -> (Text -> m ()) -> m ()
154+maybeBlank mt w = maybe blank w mt
155+
156+-- | "cursor: pointer" style.
157+pointer :: Map Text Text
158+pointer = "style" =: "cursor:pointer;"
159+
160+table :: DomBuilder t m => m a -> m a
161+table = el "table"
162+
163+thead :: DomBuilder t m => m a -> m a
164+thead = el "thead"
165+
166+tbody :: DomBuilder t m => m a -> m a
167+tbody = el "tbody"
168+
169+th :: DomBuilder t m => m a -> m a
170+th = el "th"
171+
172+tr :: DomBuilder t m => m a -> m a
173+tr = el "tr"
174+
175+td :: DomBuilder t m => m a -> m a
176+td = el "td"
177+
178+form :: DomBuilder t m => Map Text Text -> m a -> m a
179+form attrs = elAttr "form" attrs
180+
181+-- | Join event of event into single event.
182+joinE
183+ :: (Reflex t, MonadHold t m)
184+ => Event t (Event t a)
185+ -> m (Event t a)
186+joinE = switchHold never
187+
188+-- | Separate an event to two sequences based on given predicate.
189+-- The first element of resulting pair keeps events for which the predicate
190+-- holds, the second -- those for which it doesn't.
191+separateE
192+ :: Reflex t
193+ => (a -> Bool)
194+ -> Event t a
195+ -> (Event t a, Event t a)
196+separateE p e = (ffilter p e, ffilter (not . p) e)
197+
198+-- | Separate an event with optional payload.
199+-- The first event in the resulting pair keeps @Just@s, the seconds keeps
200+-- @Nothing@s.
201+separateMaybeE
202+ :: Reflex t
203+ => Event t (Maybe a)
204+ -> (Event t (Maybe a), Event t (Maybe a))
205+separateMaybeE = separateE isJust
206+
207+-- | Filter only events with existing payload.
208+fromMaybeE
209+ :: Reflex t
210+ => Event t (Maybe a)
211+ -> Event t a
212+fromMaybeE = fmapMaybe id
213+
214+-- | Separate an event with alternative payload.
215+-- The first event in the resulting pair keeps @Left@s, the seconds keeps
216+-- @Right@s.
217+separateEitherE
218+ :: Reflex t
219+ => Event t (Either a b)
220+ -> (Event t (Either a b), Event t (Either a b))
221+separateEitherE = separateE isLeft
222+
223+-- | Assigns HTML content to an element, allows embedding of arbitrary
224+-- HTML tags, so make sure you trust the source of the second argument
225+-- @
226+-- el <- _element_raw . fst <$> el' "span" blank
227+-- unsafeInnerHTML el "this text will be <i>italicised</i>"
228+-- @
229+unsafeInnerHTML :: (MonadJSM m, ToJSVal rawelem) => rawelem -> Text -> m ()
230+unsafeInnerHTML rel html = liftJSM $ do
231+ htmlVal <- toJSVal html
232+ relVal <- toJSVal rel
233+ JS.setProp "innerHTML" htmlVal (JS.Object relVal)
234+
235+-- | input element which is changes while edited.
236+-- It is useful to input dates, phones etc
237+inputCorrect
238+ :: (MonadFix m, DomBuilder t m, MonadHold t m)
239+ => (Text -> Text -> Text) -- ^ old value and new value
240+ -> InputElementConfig er t (DomBuilderSpace m)
241+ -> m (InputElement er (DomBuilderSpace m) t)
242+inputCorrect correct ec = mdo
243+ ie <- inputElement $ ec & inputElementConfig_setValue .~ eNewValue
244+ dV <- holdUniqDyn $ value ie
245+ let
246+ eNewValue = attachWith correct (current dV)
247+ $ leftmost [ec ^. inputElementConfig_setValue, updated dV]
248+ pure ie
249+
250+-- | input element in form "__/__" (e.g. for credit card)
251+inputMonth
252+ :: (MonadFix m, DomBuilder t m, MonadHold t m)
253+ => InputElementConfig er t (DomBuilderSpace m)
254+ -> m (InputElement er (DomBuilderSpace m) t)
255+inputMonth ec = inputCorrect correct $ ec
256+ & initialAttributes %~ (<> "type" =: "text" <> "maxlength" =: "5")
257+ where
258+ correct ov nv = case (T.length ov, T.length nv) of
259+ (x,2) | x < 2 -> nv <> "/"
260+ (x,3) | x > 3 -> T.take 2 nv
261+ (_, x) | x > 2 && T.head (T.drop 2 nv) /= '/' ->
262+ T.take 5 $ T.take 2 nv <> "/" <> T.drop 2 nv
263+ _ -> nv