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
|
module Component.Input
( In(..)
, Out(..)
, view
, defaultIn
) where
import qualified Data.Map as M
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (NominalDiffTime)
import Data.Validation (Validation (Failure, Success))
import qualified Data.Validation as V
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex,
(&), (.~))
import qualified Reflex.Dom as R
import qualified Common.Util.Validation as ValidationUtil
import qualified Component.Button as Button
import qualified View.Icon as Icon
data In a = In
{ _in_hasResetButton :: Bool
, _in_label :: Text
, _in_initialValue :: Text
, _in_inputType :: Text
, _in_validation :: Text -> Validation Text a
}
defaultIn :: In Text
defaultIn = In
{ _in_hasResetButton = True
, _in_label = ""
, _in_initialValue = ""
, _in_inputType = "text"
, _in_validation = V.Success
}
data Out t a = Out
{ _out_raw :: Dynamic t Text
, _out_value :: Dynamic t (Validation Text a)
, _out_enter :: Event t ()
}
view
:: forall t m a b. MonadWidget t m
=> In a
-> Event t Text -- reset
-> Event t b -- validate
-> m (Out t a)
view input reset validate = do
rec
let resetValue = R.leftmost
[ reset
, fmap (const "") resetClic
]
inputAttr = R.ffor value (\v ->
if T.null v && _in_inputType input /= "date" && _in_inputType input /= "color"
then M.empty
else M.singleton "class" "filled")
value = R._textInput_value textInput
containerAttr = R.ffor inputError (\e ->
M.singleton "class" $ T.intercalate " "
[ "textInput"
, if Maybe.isJust e then "error" else ""
])
let valueWithValidation = R.ffor value (\v -> (v, _in_validation input $ v))
inputError <- getInputError valueWithValidation validate
(textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
textInput <- R.el "label" $ do
textInput <- R.textInput $ R.def
& R.attributes .~ inputAttr
& R.setValue .~ resetValue
& R.textInputConfig_initialValue .~ (_in_initialValue input)
& R.textInputConfig_inputType .~ (_in_inputType input)
R.divClass "label" $
R.text (_in_label input)
return textInput
resetClic <-
if _in_hasResetButton input
then
Button._out_clic <$> (Button.view $
(Button.defaultIn Icon.cross)
{ Button._in_class = R.constDyn "reset"
, Button._in_tabIndex = Just (-1)
})
else
return R.never
R.divClass "errorMessage" $
R.dynText . fmap (Maybe.fromMaybe "") $ inputError
return (textInput, resetClic)
let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
return $ Out
{ _out_raw = value
, _out_value = fmap snd valueWithValidation
, _out_enter = enter
}
getInputError
:: forall t m a b c. MonadWidget t m
=> Dynamic t (Text, Validation Text a)
-> Event t c
-> m (Dynamic t (Maybe Text))
getInputError validatedValue validate = do
let errorDynamic = fmap (\(t, v) -> (t, validationError v)) validatedValue
errorEvent = R.updated errorDynamic
delayedError <- R.debounce (1 :: NominalDiffTime) errorEvent
fmap (fmap fst) $ R.foldDyn
(\event (err, hasBeenResetted) ->
case event of
ModifiedEvent t ->
(Nothing, T.null t)
ValidateEvent e ->
(e, False)
DelayEvent e ->
if hasBeenResetted then
(Nothing, False)
else
(e, False)
)
(Nothing, False)
(R.leftmost
[ fmap (\(t, _) -> ModifiedEvent t) errorEvent
, fmap (\(_, e) -> DelayEvent e) delayedError
, R.attachWith (\(_, e) _ -> ValidateEvent e) (R.current errorDynamic) validate
])
validationError :: (Validation Text a) -> Maybe Text
validationError (Failure e) = Just e
validationError _ = Nothing
data InputEvent
= ModifiedEvent Text
| DelayEvent (Maybe Text)
| ValidateEvent (Maybe Text)
|
