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
|
module View.Payment.Header
( widget
, HeaderIn(..)
, HeaderOut(..)
) 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 Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
import Common.Model (Category, CreatedPayment (..),
Currency, ExceedingPayer (..),
Frequency (..), Income (..), Init (..),
Payment (..), PaymentCategory,
User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
import Component (ButtonIn (..), ButtonOut (..),
InputIn (..), InputOut (..),
ModalIn (..), ModalOut (..))
import qualified Component as Component
import qualified Util.List as L
import View.Payment.Add (AddIn (..), AddOut (..))
import qualified View.Payment.Add as Add
data HeaderIn t = HeaderIn
{ _headerIn_init :: Init
, _headerIn_payments :: Dynamic t [Payment]
, _headerIn_searchPayments :: Dynamic t [Payment]
, _headerIn_paymentCategories :: Dynamic t [PaymentCategory]
}
data HeaderOut t = HeaderOut
{ _headerOut_searchName :: Dynamic t Text
, _headerOut_searchFrequency :: Dynamic t Frequency
, _headerOut_addPayment :: Event t CreatedPayment
}
widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
widget headerIn =
R.divClass "header" $ do
addPayment <- payerAndAdd incomes payments users categories paymentCategories currency
let resetSearchName = fmap (const ()) $ addPayment
(searchName, searchFrequency) <- searchLine resetSearchName
infos (_headerIn_searchPayments headerIn) users currency
return $ HeaderOut
{ _headerOut_searchName = searchName
, _headerOut_searchFrequency = searchFrequency
, _headerOut_addPayment = addPayment
}
where
init = _headerIn_init headerIn
incomes = _init_incomes init
initPayments = _init_payments init
payments = _headerIn_payments headerIn
users = _init_users init
categories = _init_categories init
currency = _init_currency init
paymentCategories = _headerIn_paymentCategories headerIn
payerAndAdd
:: forall t m. MonadWidget t m
=> [Income]
-> Dynamic t [Payment]
-> [User]
-> [Category]
-> Dynamic t [PaymentCategory]
-> Currency
-> m (Event t CreatedPayment)
payerAndAdd incomes payments users categories paymentCategories currency = 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
addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn
{ _buttonIn_class = R.constDyn "addPayment"
, _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
, _buttonIn_waiting = R.never
, _buttonIn_tabIndex = Nothing
, _buttonIn_submit = False
})
rec
modalOut <- Component.modal $ ModalIn
{ _modalIn_show = addPaymentClic
, _modalIn_hide = R.leftmost $
[ _addOut_cancel addOut
, fmap (const ()) . _addOut_addPayment $ addOut
]
, _modalIn_content = Add.view $ AddIn
{ _addIn_categories = categories
, _addIn_paymentCategories = paymentCategories
, _addIn_cancel = _modalOut_hide modalOut
}
}
let addOut = _modalOut_content modalOut
return (_addOut_addPayment addOut)
searchLine
:: forall t m. MonadWidget t m
=> Event t ()
-> m (Dynamic t Text, Dynamic t Frequency)
searchLine reset = do
R.divClass "searchLine" $ do
searchName <- _inputOut_raw <$> (Component.input
( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name })
(const "" <$> reset)
R.never)
let frequencies = M.fromList
[ (Punctual, Msg.get Msg.Payment_PunctualMale)
, (Monthly, Msg.get Msg.Payment_MonthlyMale)
]
searchFrequency <- R._dropdown_value <$>
R.dropdown Punctual (R.constDyn frequencies) R.def
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)
|
