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