forked from jaspervdj/digestive-functors
/
Heist.hs
302 lines (275 loc) · 10.1 KB
/
Heist.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
-- | This module provides a Heist frontend for the digestive-functors library.
--
-- Disclaimer: this documentation requires very basic familiarity with
-- digestive-functors. You might want to take a quick look at this tutorial
-- first:
--
-- <https://github.com/jaspervdj/digestive-functors/blob/master/examples/tutorial.lhs>
--
-- This module exports the functions 'digestiveSplices' and
-- 'bindDigestiveSplices', and most users will not require anything else.
--
-- These splices are used to create HTML for different form elements. This way,
-- the developer doesn't have to care about setting e.g. the previous values in
-- a text field when something goes wrong.
--
-- For documentation on the different splices, see the different functions
-- exported by this module. All splices have the same name as given in
-- 'digestiveSplices'.
--
-- You can give arbitrary attributes to most of the elements (i.e. where it
-- makes sense). This means you can do e.g.:
--
-- > <dfInputTextArea ref="description" cols="20" rows="3" />
{-# LANGUAGE OverloadedStrings #-}
module Text.Digestive.Heist
( -- * Core methods
digestiveSplices
, bindDigestiveSplices
-- * Splices
, dfInputText
, dfInputTextArea
, dfInputPassword
, dfInputHidden
, dfInputSelect
, dfInputRadio
, dfInputCheckbox
, dfInputSubmit
, dfLabel
, dfForm
, dfErrorList
, dfChildErrorList
, dfSubView
) where
import Control.Monad (liftM)
import Data.Maybe (fromMaybe)
import Data.Monoid (mappend)
import Data.Text (Text)
import Text.Digestive.View
import Text.Templating.Heist
import qualified Data.Text as T
import qualified Text.XmlHtml as X
bindDigestiveSplices :: Monad m => View Text -> HeistState m -> HeistState m
bindDigestiveSplices = bindSplices . digestiveSplices
digestiveSplices :: Monad m => View Text -> [(Text, Splice m)]
digestiveSplices view =
[ ("dfInputText", dfInputText view)
, ("dfInputTextArea", dfInputTextArea view)
, ("dfInputPassword", dfInputPassword view)
, ("dfInputHidden", dfInputHidden view)
, ("dfInputSelect", dfInputSelect view)
, ("dfInputRadio", dfInputRadio view)
, ("dfInputCheckbox", dfInputCheckbox view)
, ("dfInputFile", dfInputFile view)
, ("dfInputSubmit", dfInputSubmit view)
, ("dfLabel", dfLabel view)
, ("dfForm", dfForm view)
, ("dfErrorList", dfErrorList view)
, ("dfChildErrorList", dfChildErrorList view)
, ("dfSubView", dfSubView view)
]
attr :: Bool -> (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
attr False _ = id
attr True a = (a :)
makeElement :: Text -> [X.Node] -> [(Text, Text)] -> [X.Node]
makeElement name nodes = return . flip (X.Element name) nodes
getRefAttributes :: Monad m => HeistT m (Text, [(Text, Text)])
getRefAttributes = do
node <- getParamNode
return $ case node of
X.Element _ as _ ->
let ref = fromMaybe (error $ show node ++ ": missing ref") $
lookup "ref" as
in (ref, filter ((/= "ref") . fst) as)
_ -> (error "Wrong type of node!", [])
getContent :: Monad m => HeistT m [X.Node]
getContent = liftM X.childNodes getParamNode
-- | Generate a text input field. Example:
--
-- > <dfInputText ref="user.name" />
dfInputText :: Monad m => View v -> Splice m
dfInputText view = do
(ref, attrs) <- getRefAttributes
let ref' = absoluteRef ref view
value = fieldInputText ref view
return $ makeElement "input" [] $
("type", "text") : ("id", ref') :
("name", ref') : ("value", value) : attrs
-- | Generate a text area. Example:
--
-- > <dfInputTextArea ref="user.about" />
dfInputTextArea :: Monad m => View v -> Splice m
dfInputTextArea view = do
(ref, attrs) <- getRefAttributes
let ref' = absoluteRef ref view
value = fieldInputText ref view
return $ makeElement "textarea" [X.TextNode value] $
("id", ref') : ("name", ref') : attrs
-- | Generate a password field. Example:
--
-- > <dfInputPassword ref="user.password" />
dfInputPassword :: Monad m => View v -> Splice m
dfInputPassword view = do
(ref, attrs) <- getRefAttributes
let ref' = absoluteRef ref view
value = fieldInputText ref view
return $ makeElement "input" [] $
("type", "password") : ("id", ref') :
("name", ref') : ("value", value) : attrs
-- | Generate a hidden input field. Example:
--
-- > <dfInputHidden ref="user.forgery" />
dfInputHidden :: Monad m => View v -> Splice m
dfInputHidden view = do
(ref, attrs) <- getRefAttributes
let ref' = absoluteRef ref view
value = fieldInputText ref view
return $ makeElement "input" [] $
("type", "hidden") : ("id", ref') :
("name", ref') : ("value", value) : attrs
-- | Generate a select button (also known as a combo box). Example:
--
-- > <dfInputSelect ref="user.sex" />
dfInputSelect :: Monad m => View Text -> Splice m
dfInputSelect view = do
(ref, attrs) <- getRefAttributes
let ref' = absoluteRef ref view
(choices, idx) = fieldInputChoice ref view
children = zipWith makeOption choices [0 ..]
value i = ref' `mappend` "." `mappend` T.pack (show i)
makeOption c i = X.Element "option"
(attr (idx == i) ("selected", "selected") [("value", value i)])
[X.TextNode c]
return $ makeElement "select" children $
("id", ref') : ("name", ref') : attrs
-- | Generate a number of radio buttons. Example:
--
-- > <dfInputRadio ref="user.sex" />
dfInputRadio :: Monad m => View Text -> Splice m
dfInputRadio view = do
(ref, attrs) <- getRefAttributes
let ref' = absoluteRef ref view
(choices, idx) = fieldInputChoice ref view
children = concat $ zipWith makeOption choices [0 ..]
value i = ref' `mappend` "." `mappend` T.pack (show i)
makeOption c i =
[ X.Element "input"
(attr (idx == i) ("checked", "checked") $
("type", "radio") : ("value", value i) :
("id", value i) : ("name", ref') :
attrs ) []
, X.Element "label" [("for", value i)] [X.TextNode c]
]
return children
-- | Generate a checkbox. Example:
--
-- > <dfInputCheckbox ref="user.married" />
dfInputCheckbox :: Monad m => View Text -> Splice m
dfInputCheckbox view = do
(ref, attrs) <- getRefAttributes
let ref' = absoluteRef ref view
value = fieldInputBool ref view
return $ makeElement "input" [] $ attr value ("checked", "checked") $
("type", "checkbox") : ("id", ref') : ("name", ref') : attrs
-- | Generate a file upload element. Example:
--
-- > <dfInputFile ref="user.avatar" />
dfInputFile :: Monad m => View Text -> Splice m
dfInputFile view = do
(ref, attrs) <- getRefAttributes
let ref' = absoluteRef ref view
value = maybe "" T.pack $ fieldInputFile ref view
return $ makeElement "input" [] $
("type", "file") : ("id", ref') :
("name", ref') : ("value", value) : attrs
-- | Generate a submit button. Example:
--
-- > <dfInputSubmit />
dfInputSubmit :: Monad m => View v -> Splice m
dfInputSubmit _ = do
(_, attrs) <- getRefAttributes
return $ makeElement "input" [] $ ("type", "submit") : attrs
-- | Generate a label for a field. Example:
--
-- > <dfLabel ref="user.married">Married: </dfLabel>
-- > <dfInputCheckbox ref="user.married" />
dfLabel :: Monad m => View v -> Splice m
dfLabel view = do
(ref, attrs) <- getRefAttributes
content <- getContent
let ref' = absoluteRef ref view
return $ makeElement "label" content $ ("for", ref') : attrs
-- | Generate a form tag with the @method@ attribute set to @POST@ and
-- the @enctype@ set to the right value (depending on the form).
-- Custom @method@ or @enctype@ attributes would override this
-- behavior. Example:
--
-- > <dfForm action="/users/new">
-- > <dfInputText ... />
-- > ...
-- > <dfInputSubmit />
-- > </dfForm>
dfForm :: Monad m => View v -> Splice m
dfForm view = do
(_, attrs) <- getRefAttributes
content <- getContent
return $ makeElement "form" content $
attrs ++
[ ("method", "POST")
, ("enctype", T.pack (show $ viewEncType view)) ]
errorList :: [Text] -> [(Text, Text)] -> [X.Node]
errorList [] _ = []
errorList errs attrs = [X.Element "ul" attrs $ map makeError errs]
where
makeError e = X.Element "li" [] [X.TextNode e]
-- | Display the list of errors for a certain field. Example:
--
-- > <dfErrorList ref="user.name" />
-- > <dfInputText ref="user.name" />
dfErrorList :: Monad m => View Text -> Splice m
dfErrorList view = do
(ref, attrs) <- getRefAttributes
return $ errorList (errors ref view) attrs
-- | Display the list of errors for a certain form and all forms below it. E.g.,
-- if there is a subform called @\"user\"@:
--
-- > <dfChildErrorList ref="user" />
--
-- Or display /all/ errors for the form:
--
-- > <dfChildErrorList ref="" />
dfChildErrorList :: Monad m => View Text -> Splice m
dfChildErrorList view = do
(ref, attrs) <- getRefAttributes
return $ errorList (childErrors ref view) attrs
-- | This splice allows reuse of templates by selecting some child of a form
-- tree. While this may sound complicated, it's pretty straightforward and
-- practical. Suppose we have:
--
-- > <dfInputText ref="user.name" />
-- > <dfInputText ref="user.password" />
-- >
-- > <dfInputTextArea ref="comment.body" />
--
-- You may want to abstract the @\"user\"@ parts in some other template so you
-- Don't Repeat Yourself (TM). If you create a template called @\"user-form\"@
-- with the following contents:
--
-- > <dfInputText ref="name" />
-- > <dfInputText ref="password" />
--
-- You will be able to use:
--
-- > <dfSubView ref="user">
-- > <apply template="user-form" />
-- > </dfSubView>
-- >
-- > <dfInputTextArea ref="comment.body" />
dfSubView :: Monad m => View Text -> Splice m
dfSubView view = do
(ref, _) <- getRefAttributes
content <- getContent
let view' = subView ref view
nodes <- localTS (bindDigestiveSplices view') $ runNodeList content
stopRecursion
return nodes