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
|
module Component.Input
( InputIn(..)
, InputOut(..)
, input
, defaultInputIn
) 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 Component.Button (ButtonIn (..), ButtonOut (..))
import qualified Component.Button as Button
import qualified Icon
data InputIn a = InputIn
{ _inputIn_hasResetButton :: Bool
, _inputIn_label :: Text
, _inputIn_initialValue :: Text
, _inputIn_inputType :: Text
, _inputIn_validation :: Text -> Validation Text a
}
defaultInputIn :: InputIn Text
defaultInputIn = InputIn
{ _inputIn_hasResetButton = True
, _inputIn_label = ""
, _inputIn_initialValue = ""
, _inputIn_inputType = "text"
, _inputIn_validation = V.Success
}
data InputOut t a = InputOut
{ _inputOut_raw :: Dynamic t Text
, _inputOut_value :: Dynamic t (Validation Text a)
, _inputOut_enter :: Event t ()
}
input
:: forall t m a b. MonadWidget t m
=> InputIn a
-> Event t Text -- reset
-> Event t b -- validate
-> m (InputOut t a)
input inputIn reset validate = do
rec
let resetValue = R.leftmost
[ reset
, fmap (const "") resetClic
]
inputAttr = R.ffor value (\v ->
if T.null v && _inputIn_inputType inputIn /= "date"
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, _inputIn_validation inputIn $ v))
inputError <- getInputError valueWithValidation validate
(textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
textInput <- R.textInput $ R.def
& R.attributes .~ inputAttr
& R.setValue .~ resetValue
& R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn)
& R.textInputConfig_inputType .~ (_inputIn_inputType inputIn)
R.el "label" $ R.text (_inputIn_label inputIn)
resetClic <-
if _inputIn_hasResetButton inputIn
then
_buttonOut_clic <$> (Button.button $
(Button.defaultButtonIn Icon.cross)
{ _buttonIn_class = R.constDyn "reset"
, _buttonIn_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 $ InputOut
{ _inputOut_raw = value
, _inputOut_value = fmap snd valueWithValidation
, _inputOut_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)
|
