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
|
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 qualified Data.Time as Time
import Prelude hiding (init)
import Reflex.Dom (Dynamic, 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.Util.Text as T
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
}
data HeaderOut t = HeaderOut
{ _headerOut_searchName :: Dynamic t Text
, _headerOut_searchPayments :: Dynamic t [Payment]
}
widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
widget headerIn =
R.divClass "header" $ do
payerAndAdd incomes punctualPayments users categories currency
(searchName, searchFrequency) <- searchLine
let searchPayments = getSearchPayments searchName searchFrequency payments
infos searchPayments users currency
return $ HeaderOut
{ _headerOut_searchName = searchName
, _headerOut_searchPayments = searchPayments
}
where
init = _headerIn_init headerIn
incomes = _init_incomes init
payments = _init_payments init
punctualPayments = filter ((==) Punctual . _payment_frequency) payments
users = _init_users init
categories = _init_categories init
currency = _init_currency init
getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment]
getSearchPayments name frequency payments = do
n <- name
f <- frequency
pure $ flip filter payments (\p ->
( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
&& (_payment_frequency p == f)
))
payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m ()
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
)
addPayment <- _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 = addPayment
, _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut
, _modalIn_content = Add.view $ AddIn { _addIn_categories = categories }
}
return ()
searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency)
searchLine = do
R.divClass "searchLine" $ do
searchName <- _inputOut_value <$> (Component.input $ InputIn
{ _inputIn_reset = R.never
, _inputIn_label = Msg.get Msg.Search_Name
, _inputIn_initialValue = ""
})
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)
|
