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
|
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 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)
import qualified Reflex.Dom as R
import Common.Model (Currency, ExceedingPayer (..),
Frequency (..), Income (..), Init (..),
Payment (..), User (..), UserId)
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
import Component (ButtonIn (..), InputIn (..),
InputOut (..))
import qualified Component as Component
import qualified Util.List as L
data HeaderIn t = HeaderIn
{ _headerIn_init :: Init
}
data HeaderOut t = HeaderOut
{ _headerOut_search :: Dynamic t Text
}
widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
widget headerIn =
R.divClass "header" $ do
payerAndAdd incomes payments users currency
search <- searchLine
infos payments users currency
return $ HeaderOut
{ _headerOut_search = search
}
where init = _headerIn_init headerIn
incomes = _init_incomes init
payments = filter ((==) Punctual . _payment_frequency) (_init_payments init)
users = _init_users init
currency = _init_currency init
payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m ()
payerAndAdd incomes payments users 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
)
_ <- Component.button $ ButtonIn
{ _buttonIn_class = R.constDyn "addPayment"
, _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
, _buttonIn_waiting = R.never
}
return ()
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 $ CM.findUser userId users)
(Format.price currency userTotal)
)
$ totalByUser
where paymentCount = length payments
total = sum . map _payment_cost $ payments
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))
$ payments
searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text)
searchLine =
R.divClass "searchLine" $
_inputOut_value <$> (Component.input $ InputIn
{ _inputIn_reset = R.never
, _inputIn_label = Msg.get Msg.Search_Name
})
|
