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
|
module View.Payment.Header
( view
, In(..)
, Out(..)
) where
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import qualified Data.List as L hiding (groupBy)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (NominalDiffTime)
import qualified Data.Time as Time
import qualified Data.Validation as V
import Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
import Common.Model (Category, Currency,
ExceedingPayer (..), Frequency (..),
Income (..), Payment (..),
PaymentCategory, SavedPayment (..),
User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
import qualified Component.Button as Button
import qualified Component.Input as Input
import qualified Component.Modal as Modal
import qualified Component.Select as Select
import qualified Util.List as L
import qualified View.Payment.Add as Add
import View.Payment.Init (Init (..))
data In t = In
{ _in_init :: Init
, _in_currency :: Currency
, _in_payments :: Dynamic t [Payment]
, _in_searchPayments :: Dynamic t [Payment]
, _in_paymentCategories :: Dynamic t [PaymentCategory]
}
data Out t = Out
{ _out_searchName :: Dynamic t Text
, _out_searchFrequency :: Dynamic t Frequency
, _out_addPayment :: Event t SavedPayment
}
view :: forall t m. MonadWidget t m => In t -> m (Out t)
view input =
R.divClass "header" $ do
rec
addPayment <-
payerAndAdd
incomes
payments
users
categories
paymentCategories
currency
searchFrequency
let resetSearchName = fmap (const ()) $ addPayment
(searchName, searchFrequency) <- searchLine resetSearchName
infos (_in_searchPayments input) users currency
return $ Out
{ _out_searchName = searchName
, _out_searchFrequency = searchFrequency
, _out_addPayment = addPayment
}
where
init = _in_init input
incomes = _init_incomes init
initPayments = _init_payments init
payments = _in_payments input
users = _init_users init
categories = _init_categories init
currency = _in_currency input
paymentCategories = _in_paymentCategories input
payerAndAdd
:: forall t m. MonadWidget t m
=> [Income]
-> Dynamic t [Payment]
-> [User]
-> [Category]
-> Dynamic t [PaymentCategory]
-> Currency
-> Dynamic t Frequency
-> m (Event t SavedPayment)
payerAndAdd incomes payments users categories paymentCategories currency frequency = do
time <- liftIO Time.getCurrentTime
R.divClass "payerAndAdd" $ do
let exceedingPayers =
R.ffor payments $ \ps ->
CM.getExceedingPayers time users incomes $
filter ((==) Punctual . _payment_frequency) ps
R.divClass "exceedingPayers" $
R.simpleList exceedingPayers $ \exceedingPayer ->
R.elClass "span" "exceedingPayer" $ do
R.elClass "span" "userName" $
R.dynText . R.ffor exceedingPayer $ \ep ->
fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users
R.elClass "span" "amount" $ do
R.text "+ "
R.dynText . R.ffor exceedingPayer $ \ep ->
Format.price currency $ _exceedingPayer_amount ep
addPayment <- Button._out_clic <$>
(Button.view $
(Button.defaultIn (R.text $ Msg.get Msg.Payment_Add))
{ Button._in_class = R.constDyn "addPayment"
})
Modal.view $ Modal.In
{ Modal._in_show = addPayment
, Modal._in_content = Add.view $ Add.In
{ Add._in_categories = categories
, Add._in_paymentCategories = paymentCategories
, Add._in_frequency = frequency
}
}
searchLine
:: forall t m. MonadWidget t m
=> Event t ()
-> m (Dynamic t Text, Dynamic t Frequency)
searchLine reset = do
R.divClass "searchLine" $ do
searchName <- Input._out_raw <$> (Input.view
( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
("" <$ reset)
R.never)
let frequencies = M.fromList
[ (Punctual, Msg.get Msg.Payment_PunctualMale)
, (Monthly, Msg.get Msg.Payment_MonthlyMale)
]
searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
{ Select._in_label = ""
, Select._in_initialValue = Punctual
, Select._in_value = R.never
, Select._in_values = R.constDyn frequencies
, Select._in_reset = R.never
, Select._in_isValid = V.Success
, Select._in_validate = R.never
})
return (searchName, searchFrequency)
infos
:: forall t m. MonadWidget t m
=> Dynamic t [Payment]
-> [User]
-> Currency -> m ()
infos payments users currency =
R.divClass "infos" $ do
R.elClass "span" "total" $ do
R.dynText $ do
ps <- payments
let paymentCount = length ps
total = sum . map _payment_cost $ ps
pure . Msg.get $ Msg.Payment_Worth
(T.intercalate " "
[ (Format.number paymentCount)
, if paymentCount > 1
then Msg.get Msg.Payment_Many
else Msg.get Msg.Payment_One
])
(Format.price currency total)
R.elClass "span" "partition" . R.dynText $ do
ps <- payments
let totalByUser =
L.sortBy (\(_, t1) (_, t2) -> compare t2 t1)
. map (\(u, xs) -> (u, sum . map snd $ xs))
. L.groupBy fst
. map (\p -> (_payment_user p, _payment_cost p))
$ ps
pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) ->
Msg.get $ Msg.Payment_By
(fromMaybe "" . fmap _user_name $ CM.findUser userId users)
(Format.price currency userTotal)
|
