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
|
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, Currency,
ExceedingPayer (..), Frequency (..),
Income (..), Init (..), Payment (..),
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_searchPayments :: Dynamic t [Payment]
}
data HeaderOut t = HeaderOut
{ _headerOut_searchName :: Dynamic t Text
, _headerOut_searchFrequency :: Dynamic t Frequency
, _headerOut_addedPayment :: Event t Payment
}
widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
widget headerIn =
R.divClass "header" $ do
addedPayment <- payerAndAdd incomes punctualPayments users categories currency
let resetSearchName = fmap (const ()) $ addedPayment
(searchName, searchFrequency) <- searchLine resetSearchName
infos (_headerIn_searchPayments headerIn) users currency
return $ HeaderOut
{ _headerOut_searchName = searchName
, _headerOut_searchFrequency = searchFrequency
, _headerOut_addedPayment = addedPayment
}
where
init = _headerIn_init headerIn
incomes = _init_incomes init
initPayments = _init_payments init
punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments
users = _init_users init
categories = _init_categories init
currency = _init_currency init
payerAndAdd
:: forall t m. MonadWidget t m
=> [Income]
-> [Payment]
-> [User]
-> [Category]
-> Currency
-> m (Event t Payment)
payerAndAdd incomes payments users categories currency = do
time <- liftIO Time.getCurrentTime
R.divClass "payerAndAdd" $ do
R.divClass "exceedingPayers" $
forM_
(CM.getExceedingPayers time users incomes payments)
(\p ->
R.elClass "span" "exceedingPayer" $ do
R.elClass "span" "userName" $
R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users
R.elClass "span" "amount" $ do
R.text "+ "
R.text . Format.price currency $ _exceedingPayer_amount p
)
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 <- fmap _modalOut_content . Component.modal $ ModalIn
{ _modalIn_show = addPaymentClic
, _modalIn_hide = R.leftmost $
[ _addOut_cancel modalOut
, fmap (const ()) . _addOut_addedPayment $ modalOut
]
, _modalIn_content = Add.view $ AddIn
{ _addIn_categories = categories
, _addIn_show = addPaymentClic
}
}
return (_addOut_addedPayment modalOut)
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_value <$> (Component.input
( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name })
reset)
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)
|
