/
Validation.purs
324 lines (284 loc) · 12 KB
/
Validation.purs
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
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
module Lumi.Components.Form.Validation
( Validator
, nonEmpty, nonEmptyArray, nonNull
, mustEqual, mustBe
, validNumber, validInt, validDate
, optional
, Validated(..)
, _Validated, _Fresh, _Modified
, setFresh, setModified
, ModifyValidated(..)
, class CanValidate, fresh, modified, fromValidated
, validated
, warn
) where
import Prelude
import Data.Array as Array
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty (fromArray) as NEA
import Data.Date as Date
import Data.Either (Either(..), either, hush, note)
import Data.Enum (toEnum)
import Data.Eq (class Eq1)
import Data.Foldable (foldMap)
import Data.Int as Int
import Data.Lens (Lens, Prism', lens, over, prism', review, view)
import Data.Maybe (Maybe(..))
import Data.Monoid (guard)
import Data.Newtype (un)
import Data.Nullable (notNull)
import Data.Number as Number
import Data.Ord (class Ord1)
import Data.String.Common (split)
import Data.String.NonEmpty (NonEmptyString)
import Data.String.NonEmpty (fromString) as NES
import Data.String.Pattern (Pattern(..))
import Data.Traversable (traverse)
import Heterogeneous.Mapping (class MapRecordWithIndex, class Mapping, ConstMapping, hmap, mapping)
import Lumi.Components.Column (column)
import Lumi.Components.Form.Internal (Forest, FormBuilder, FormBuilder'(..), Tree(..))
import Lumi.Components.LabeledField (ValidationMessage(..))
import Lumi.Components.Text (subtext, text)
import Prim.RowList as RL
import React.Basic (JSX)
import React.Basic.DOM as R
-- | A `Validator` takes a possibly invalid form `result` and produces
-- | a `valid` result, or an error message.
type Validator result valid =
result -> Either String valid
-- | A `WarningValidator` can be used to issue a message to the user on
-- | certain form data, but cannot cause the form to fail. Accordingly,
-- | it cannot modify the form data value or type.
type WarningValidator result =
result -> Maybe String
-- | A `Validator` which verifies that an input string is non-empty.
nonEmpty :: String -> Validator String NonEmptyString
nonEmpty name = note (name <> " is required.") <<< NES.fromString
-- | A `Validator` which verifies that an input array is non-empty.
nonEmptyArray :: forall a. String -> Validator (Array a) (NonEmptyArray a)
nonEmptyArray name = note (name <> " cannot be empty.") <<< NEA.fromArray
-- | A `Validator` which verifies that an optional field is specified.
nonNull :: forall a. String -> Validator (Maybe a) a
nonNull name = note (name <> " is required.")
-- | A `Validator` which verifies that its input equals some value.
mustEqual :: forall a. Eq a => a -> String -> Validator a a
mustEqual value1 = mustBe (_ == value1)
-- | A `Validator` which verifies that its input fulfills a specified condition.
mustBe :: forall a. (a -> Boolean) -> String -> Validator a a
mustBe cond error value
| cond value = pure value
| otherwise = Left error
-- | A `Validator` which verifies that its input can be parsed as a number.
validNumber :: String -> Validator String Number
validNumber name = note (name <> " must be a number.") <<< Number.fromString
-- | A `Validator` which verifies that its input can be parsed as an integer.
validInt :: String -> Validator String Int
validInt name = note (name <> " must be a whole number.") <<< Int.fromString
-- | A `Validator` which verifies that its input can be parsed as a date.
-- | Dates are of the format "YYYY-MM-DD".
validDate :: String -> Validator String Date.Date
validDate name input =
note (name <> " must be a date.") result
where
result = case traverse Int.fromString $ split (Pattern "-") input of
Just [y, m, d] -> join $ Date.exactDate <$> toEnum y <*> toEnum m <*> toEnum d
_ -> Nothing
-- | Modify a `Validator` to accept empty strings in addition to anything it
-- | already accepts. The empty string is mapped to `Nothing`, and any other
-- | valid input is mapped to `Just` the result of the original validator.
optional :: forall a. Validator String a -> Validator String (Maybe a)
optional _ "" = pure Nothing
optional v s = map Just (v s)
-- | The `Validated` type describes the state of a validated form field. This
-- | state may be used to modify the way this form field or its validation
-- | messages are displayed.
-- |
-- | TODO: maybe convert this type to a record? Possible extensions to this
-- | type (as a record) could be a field `valid :: Boolean` to display an
-- | indicator that the field is valid, or a field
-- | `validating :: Maybe (Canceler a)` to control form fields with asynchronous
-- | validation.
data Validated a
= Fresh a
| Modified a
derive instance eqValidated :: Eq a => Eq (Validated a)
derive instance eq1Validated :: Eq1 Validated
derive instance ordValidated :: Ord a => Ord (Validated a)
derive instance ord1Validated :: Ord1 Validated
derive instance functorValidated :: Functor Validated
instance applyValidated :: Apply Validated where
apply (Fresh f) r = f <$> r
apply (Modified f) (Fresh a) = Modified (f a)
apply (Modified f) (Modified a) = Modified (f a)
instance applicativeValidated :: Applicative Validated where
pure = Fresh
-- | Lens for viewing and modifying `Validated` values.
_Validated :: forall a b. Lens (Validated a) (Validated b) a b
_Validated = flip lens ($>) $
case _ of
Fresh a -> a
Modified a -> a
-- | Prism for the `Fresh` constructor of `Validated`.
_Fresh :: forall a. Prism' (Validated a) a
_Fresh = prism' Fresh $
case _ of
Fresh a -> Just a
_ -> Nothing
-- | Prism for the `Modified` constructor of `Validated`.
_Modified :: forall a. Prism' (Validated a) a
_Modified = prism' Modified $
case _ of
Modified a -> Just a
_ -> Nothing
-- | Sets all `Validated` fields in a record to `Fresh`, hiding all validation
-- | messages.
setFresh
:: forall value
. Mapping ModifyValidated value value
=> value
-> value
setFresh = mapping (ModifyValidated (Fresh <<< view _Validated))
-- | Sets all `Validated` fields in a record to `Modified`, showing all
-- | validation messages.
setModified
:: forall value
. Mapping ModifyValidated value value
=> value
-> value
setModified = mapping (ModifyValidated (Modified <<< view _Validated))
-- | Internal utility type for modifying the validated state of fields in
-- | records containing `Validated` values.
newtype ModifyValidated = ModifyValidated (Validated ~> Validated)
instance modifyValidated :: Mapping ModifyValidated a a => Mapping ModifyValidated (Validated a) (Validated a) where
mapping m@(ModifyValidated f) = over _Validated (mapping m) <<< f
else instance modifyValidatedRecord :: (RL.RowToList r xs, MapRecordWithIndex xs (ConstMapping ModifyValidated) r r) => Mapping ModifyValidated {| r} {| r} where
mapping d = hmap d
else instance modifyValidatedArray :: Mapping ModifyValidated a a => Mapping ModifyValidated (Array a) (Array a) where
mapping d = map (mapping d)
else instance modifyValidatedIdentity :: Mapping ModifyValidated a a where
mapping _ = identity
-- | Internal utility type class used to flatten repeated applications of
-- | `Validated` to a type.
class CanValidate u v | u -> v where
fresh :: Prism' (Validated v) u
modified :: Prism' (Validated v) u
fromValidated :: Validated v -> u
instance canValidateValidated :: CanValidate (Validated a) a where
fresh = identity
modified = identity
fromValidated = identity
else instance canValidateAny :: CanValidate a a where
fresh = _Fresh
modified = _Modified
fromValidated = view _Validated
-- | Attach a validation function to a `FormBuilder p u a`, producing a new
-- | `FormBuilder` that takes a `Validated u` as form state and displays an
-- | error message if its form data is invalid.
-- |
-- | This `Validated` data type describes a form field as either `Fresh` or
-- | `Modified`, so that validation messages are only displayed if the field
-- | is `Modified`.
validated
:: forall props unvalidated validated result result_
. CanValidate unvalidated validated
=> Validator result_ result
-> FormBuilder { readonly :: Boolean | props } unvalidated result_
-> FormBuilder { readonly :: Boolean | props } (Validated validated) result
validated runValidator editor = FormBuilder \props@{ readonly } v ->
let value = fromValidated v
innerColumn_ children =
column
{ style: R.css { maxWidth: "100%", maxHeight: "100%" }
, children
}
{ edit, validate } = un FormBuilder editor props value
modify :: Maybe String -> Forest -> Forest
modify message forest =
case Array.unsnoc forest of
Nothing -> [Child { key: Nothing, child: errLine }]
Just { init, last: Child c } ->
Array.snoc init (Child c { child = innerColumn_ [c.child, errLine] })
Just { init, last: Wrapper c } ->
Array.snoc init (Wrapper c { children = modify message c.children })
Just { init, last: Node n } ->
Array.snoc init (Node n { validationError = Error <$> message })
where
errLine =
guard (not readonly) message # foldMap \s ->
case Error s of
Error e ->
text subtext
{ className = notNull "labeled-field--validation-error"
, children = [ R.text e ]
}
Warning w ->
text subtext
{ className = notNull "labeled-field--validation-warning"
, children = [ R.text w ]
}
-- The validation can produce either a valid result, an error message, or
-- none in the case where the form is Fresh.
res :: Maybe (Either String result)
res = do
valid <- validate
case v of
Fresh _ ->
pure <$> hush (runValidator valid)
_ ->
pure $ runValidator valid
err = either pure (const Nothing) =<< res
in { edit: \onChange -> (modify err <<< edit) (onChange <<< \f ->
case _ of
v'@(Fresh u) -> review modified (f (fromValidated v'))
v'@(Modified u) -> review modified (f (fromValidated v'))
)
, validate: hush =<< res
}
-- | Attach a validation function to a `FormBuilder p u a`, producing a new
-- | `FormBuilder` that takes a `Validated u` as form state and displays a
-- | warning message if its form data triggers a warning, while still allowing
-- | the form to proceed.
warn
:: forall props unvalidated validated result
. CanValidate unvalidated validated
=> WarningValidator result
-> FormBuilder { readonly :: Boolean | props } unvalidated result
-> FormBuilder { readonly :: Boolean | props } (Validated validated) result
warn warningValidator editor = FormBuilder \props@{ readonly } v ->
let { edit, validate } = un FormBuilder editor props (fromValidated v)
innerColumn_ children =
column
{ style: R.css { maxWidth: "100%", maxHeight: "100%" }
, children
}
modify :: Forest -> Forest
modify forest =
case Array.unsnoc forest of
Nothing -> [Child { key: Nothing, child: errLine }]
Just { init, last: Child c } ->
Array.snoc init (Child c { child = innerColumn_ [c.child, errLine] })
Just { init, last: Wrapper c } ->
Array.snoc init (Wrapper c { children = modify c.children })
Just { init, last: Node n } ->
Array.snoc init (Node n { validationError = Warning <$> message })
errLine :: JSX
errLine =
guard (not readonly) message # foldMap \s ->
text subtext
{ className = notNull "labeled-field--validation-warning"
, children = [ R.text s ]
}
message :: Maybe String
message =
case v of
Fresh _ ->
Nothing
_ ->
warningValidator =<< validate
in { edit: \onChange -> (modify <<< edit) (onChange <<< \f ->
case _ of
v'@(Fresh u) -> review modified (f (fromValidated v'))
v'@(Modified u) -> review modified (f (fromValidated v'))
)
, validate
}