From bab2c30addf8aaed85675e2b7f7b15c97c426f74 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 15:00:07 +0100 Subject: Add exceeding payer block --- client/src/Component/Button.hs | 6 ---- client/src/Icon.hs | 4 +-- client/src/View/Payment.hs | 8 +++-- client/src/View/Payment/Header.hs | 66 ++++++++++++++++++++++++++++----------- 4 files changed, 55 insertions(+), 29 deletions(-) (limited to 'client/src') diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 09c93cd..754b903 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -48,9 +48,3 @@ button buttonIn = do return $ ButtonOut { _buttonOut_clic = R.domEvent R.Click e } - --- mergeAttr :: Map Text Text -> Map Text Text -> Map Text Text --- mergeAttr = M.unionWithKey $ \k a b -> --- if k == "class" --- then T.intercalate " " [ a, b ] --- else b diff --git a/client/src/Icon.hs b/client/src/Icon.hs index fbf5388..e04e2a8 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -58,8 +58,8 @@ loading = signOut :: forall t m. MonadWidget t m => m () signOut = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank + svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 934f720..15892c4 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -4,6 +4,7 @@ module View.Payment , PaymentOut(..) ) where +import Prelude hiding (init) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R @@ -29,13 +30,14 @@ widget paymentIn = do R.divClass "payment" $ do rec _ <- Header.widget $ HeaderIn - { _headerIn_init = _paymentIn_init $ paymentIn + { _headerIn_init = init } _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn + { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pagesOut } pagesOut <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn + { _pagesIn_payments = _init_payments init } return $ PaymentOut {} + where init = _paymentIn_init paymentIn diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 67b4eb4..3f2adc3 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -4,22 +4,29 @@ module View.Payment.Header , 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 Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L hiding (groupBy) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Time as Time +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 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 qualified Util.List as L +import Component (ButtonIn (..)) +import qualified Component as Component +import qualified Util.List as L data HeaderIn t = HeaderIn - { _headerIn_init :: Init + { _headerIn_init :: Init } data HeaderOut = HeaderOut @@ -29,13 +36,37 @@ data HeaderOut = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut widget headerIn = R.divClass "header" $ do + payerAndAdd incomes payments users currency infos payments users currency return $ HeaderOut {} where init = _headerIn_init headerIn - payments = _init_payments init + 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 @@ -52,14 +83,13 @@ infos payments users currency = T.intercalate ", " . map (\(userId, userTotal) -> Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users) + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) (Format.price currency userTotal) ) $ totalByUser - where punctualPayments = filter ((==) Punctual . _payment_frequency) payments - paymentCount = length punctualPayments - total = sum . map _payment_cost $ punctualPayments + where paymentCount = length payments + total = sum . map _payment_cost $ payments totalByUser :: [(UserId, Int)] totalByUser = @@ -67,4 +97,4 @@ infos payments users currency = . map (\(u, xs) -> (u, sum . map snd $ xs)) . L.groupBy fst . map (\p -> (_payment_user p, _payment_cost p)) - $ punctualPayments + $ payments -- cgit v1.2.3