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
|
module View.Income.Form
( view
, FormIn(..)
, HttpMethod(..)
, FormOut(..)
) where
import Data.Aeson (ToJSON)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import qualified Data.Time.Calendar as Calendar
import qualified Data.Validation as V
import Reflex.Dom (Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Income)
import qualified Common.Msg as Msg
import qualified Common.Validation.Income as IncomeValidation
import Component (ButtonIn (..), InputIn (..),
InputOut (..))
import qualified Component as Component
import qualified Util.Ajax as Ajax
import qualified Util.Either as EitherUtil
import qualified Util.Validation as ValidationUtil
import qualified Util.WaitFor as WaitFor
data FormIn t i = FormIn
{ _formIn_cancel :: Event t ()
, _formIn_headerLabel :: Text
, _formIn_amount :: Text
, _formIn_date :: Day
, _formIn_mkPayload :: Text -> Text -> i
, _formIn_httpMethod :: HttpMethod
}
data HttpMethod = Put | Post
data FormOut t = FormOut
{ _formOut_hide :: Event t ()
, _formOut_addIncome :: Event t Income
}
view :: forall t m i. (MonadWidget t m, ToJSON i) => FormIn t i -> m (FormOut t)
view formIn = do
R.divClass "form" $ do
R.divClass "formHeader" $
R.text (_formIn_headerLabel formIn)
R.divClass "formContent" $ do
rec
let reset = R.leftmost
[ "" <$ cancel
, "" <$ addIncome
, "" <$ _formIn_cancel formIn
]
amount <- _inputOut_raw <$> (Component.input
(Component.defaultInputIn
{ _inputIn_label = Msg.get Msg.Income_Amount
, _inputIn_initialValue = _formIn_amount formIn
, _inputIn_validation = IncomeValidation.amount
})
(_formIn_amount formIn <$ reset)
confirm)
let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn
date <- _inputOut_raw <$> (Component.input
(Component.defaultInputIn
{ _inputIn_label = Msg.get Msg.Income_Date
, _inputIn_initialValue = initialDate
, _inputIn_inputType = "date"
, _inputIn_hasResetButton = False
, _inputIn_validation = IncomeValidation.date
})
(initialDate <$ reset)
confirm)
let income = do
a <- amount
d <- date
return . V.Success $ (_formIn_mkPayload formIn) a d
(addIncome, cancel, confirm) <- R.divClass "buttons" $ do
rec
cancel <- Component._buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
{ _buttonIn_class = R.constDyn "undo" })
confirm <- Component._buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
{ _buttonIn_class = R.constDyn "confirm"
, _buttonIn_waiting = waiting
, _buttonIn_submit = True
})
(addIncome, waiting) <- WaitFor.waitFor
(ajax "/api/income")
(ValidationUtil.fireValidation income confirm)
return (R.fmapMaybe EitherUtil.eitherToMaybe addIncome, cancel, confirm)
return FormOut
{ _formOut_hide = R.leftmost [ cancel, () <$ addIncome ]
, _formOut_addIncome = addIncome
}
where
ajax =
case _formIn_httpMethod formIn of
Post -> Ajax.postJson
Put -> Ajax.putJson
|
