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
|
module View.Payment.Header
( widget
, HeaderIn(..)
, HeaderOut(..)
) where
import qualified Data.List as L hiding (groupBy)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Prelude hiding (init)
import Reflex.Dom (MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Currency, Frequency (..), Init (..),
Payment (..), User (..), UserId)
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
import qualified Util.List as L
data HeaderIn t = HeaderIn
{ _headerIn_init :: Init
}
data HeaderOut = HeaderOut
{
}
widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut
widget headerIn =
R.divClass "header" $ do
infos payments users currency
return $ HeaderOut {}
where init = _headerIn_init headerIn
payments = _init_payments init
users = _init_users init
currency = _init_currency init
infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m ()
infos payments users currency =
R.divClass "infos" $ do
R.elClass "span" "total" $ do
R.text . 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.text $
T.intercalate ", "
. map (\(userId, userTotal) ->
Msg.get $ Msg.Payment_By
(fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users)
(Format.price currency userTotal)
)
$ totalByUser
where punctualPayments = filter ((==) Punctual . _payment_frequency) payments
paymentCount = length punctualPayments
total = sum . map _payment_cost $ punctualPayments
totalByUser :: [(UserId, Int)]
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))
$ punctualPayments
|
