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
|
module View.Payment.Add
( view
, AddIn(..)
, AddOut(..)
) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.Map as M
import qualified Data.Maybe as Maybe
import qualified Data.Text as T
import qualified Data.Time.Calendar as Calendar
import qualified Data.Time.Clock as Time
import Reflex.Dom (Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
import qualified Text.Read as T
import Common.Model (Category (..), CreatePayment (..),
Frequency (..), Payment (..))
import qualified Common.Msg as Msg
import qualified Common.Util.Time as Time
import Component (ButtonIn (..), InputIn (..),
InputOut (..), SelectIn (..),
SelectOut (..))
import qualified Component as Component
import qualified Util.Ajax as Ajax
import qualified Util.Either as EitherUtil
import qualified Util.WaitFor as WaitFor
data AddIn t = AddIn
{ _addIn_categories :: [Category]
, _addIn_show :: Event t ()
}
data AddOut t = AddOut
{ _addOut_cancel :: Event t ()
, _addOut_addedPayment :: Event t Payment
}
view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t)
view addIn = do
R.divClass "add" $ do
R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add
R.divClass "addContent" $ do
name <- _inputOut_value <$> (Component.input
(Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
(_addIn_show addIn))
cost <- _inputOut_value <$> (Component.input
(Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
(_addIn_show addIn))
currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
date <- _inputOut_value <$> (Component.input
(Component.defaultInputIn
{ _inputIn_label = Msg.get Msg.Payment_Date
, _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay
, _inputIn_inputType = "date"
, _inputIn_hasResetButton = False
})
(_addIn_show addIn))
frequency <- _selectOut_value <$> (Component.select $ SelectIn
{ _selectIn_label = Msg.get Msg.Payment_Frequency
, _selectIn_initialValue = Punctual
, _selectIn_values = R.constDyn frequencies
, _selectIn_reset = _addIn_show addIn
})
category <- _selectOut_value <$> (Component.select $ SelectIn
{ _selectIn_label = Msg.get Msg.Payment_Category
, _selectIn_initialValue = 0
, _selectIn_values = R.constDyn categories
, _selectIn_reset = _addIn_show addIn
})
let payment = CreatePayment
<$> name
<*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost
<*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date
<*> category
<*> frequency
(addedPayment, cancel) <- R.divClass "buttons" $ do
rec
validate <- 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
})
(result, waiting) <- WaitFor.waitFor
(Ajax.postJson "/payment")
validate
payment
cancel <- Component._buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
{ _buttonIn_class = R.constDyn "undo" })
return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
return AddOut
{ _addOut_cancel = cancel
, _addOut_addedPayment = addedPayment
}
where
frequencies = M.fromList
[ (Punctual, Msg.get Msg.Payment_PunctualMale)
, (Monthly, Msg.get Msg.Payment_MonthlyMale)
]
categories = M.fromList . flip map (_addIn_categories addIn) $ \c ->
(_category_id c, _category_name c)
|
