From f4f24158a46d8c0975f1b8813bbdbbeebad8c108 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 6 Nov 2019 19:44:15 +0100 Subject: Show the payment table with server side paging --- client/src/View/Payment/Payment.hs | 367 ++++++++++++++++++++----------------- 1 file changed, 202 insertions(+), 165 deletions(-) (limited to 'client/src/View/Payment/Payment.hs') diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index e72577f..bf0186f 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -1,181 +1,218 @@ module View.Payment.Payment - ( init - , view + ( view , In(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Frequency, Income (..), - Payment (..), PaymentCategory (..), - PaymentId, SavedPayment (..), User, - UserId) -import qualified Common.Util.Text as T - -import Loadable (Loadable (..)) +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentCategory (..), + PaymentId, PaymentPage (..), + SavedPayment (..), User, UserId) +import qualified Common.Util.Text as T + +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) import qualified Loadable -import qualified Util.Ajax as AjaxUtil -import qualified View.Payment.Header as Header -import View.Payment.Init (Init (..)) -import qualified View.Payment.Pages as Pages -import qualified View.Payment.Table as Table - -init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) -init = do - users <- AjaxUtil.getNow "api/users" - payments <- AjaxUtil.getNow "api/payments" - incomes <- AjaxUtil.getNow "api/deprecated/incomes" - categories <- AjaxUtil.getNow "api/categories" - paymentCategories <- AjaxUtil.getNow "api/paymentCategories" - return $ do - us <- users - ps <- payments - is <- incomes - cs <- categories - pcs <- paymentCategories - return $ Init <$> us <*> ps <*> is <*> cs <*> pcs - +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Header as Header +import View.Payment.Init (Init (..)) +import qualified View.Payment.Reducer as Reducer +import qualified View.Payment.Table as Table data In t = In { _in_currentUser :: UserId + , _in_users :: [User] , _in_currency :: Currency - , _in_init :: Dynamic t (Loadable Init) } view :: forall t m. MonadWidget t m => In t -> m () view input = do - R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> - - R.elClass "main" "payment" $ do - rec - let addPayment = R.leftmost - [ Header._out_addPayment header - , Table._out_addPayment table - ] - - paymentsPerPage = 7 - - payments <- reducePayments - (_init_payments init) - (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> Table._out_editPayment table) - (Table._out_deletePayment table) - - paymentCategories <- reducePaymentCategories - (_init_paymentCategories init) - payments - (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> Table._out_editPayment table) - (Table._out_deletePayment table) - - (searchNameEvent, searchName) <- - debounceSearchName (Header._out_searchName header) - - let searchPayments = - getSearchPayments searchName (Header._out_searchFrequency header) payments - - header <- Header.view $ Header.In - { Header._in_init = init - , Header._in_currency = _in_currency input - , Header._in_payments = payments - , Header._in_searchPayments = searchPayments - , Header._in_paymentCategories = paymentCategories - } - - table <- Table.view $ Table.In - { Table._in_init = init - , Table._in_currency = _in_currency input - , Table._in_currentUser = _in_currentUser input - , Table._in_currentPage = Pages._out_currentPage pages - , Table._in_payments = searchPayments - , Table._in_perPage = paymentsPerPage - , Table._in_paymentCategories = paymentCategories - } - - pages <- Pages.view $ Pages.In - { Pages._in_total = length <$> searchPayments - , Pages._in_perPage = paymentsPerPage - , Pages._in_reset = R.leftmost $ - [ () <$ searchNameEvent - , () <$ Header._out_addPayment header - ] - } - - pure () + + categoriesEvent <- (AjaxUtil.getNow "api/categories") + + R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do + + rec + payments <- Reducer.reducer $ Reducer.In + { Reducer._in_newPage = newPage + , Reducer._in_currentPage = currentPage + , Reducer._in_addPayment = R.leftmost [headerAddPayment, tableAddPayment] + , Reducer._in_editPayment = editPayment + , Reducer._in_deletePayment = deletePayment + } + + let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result + + newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) + currentPage <- R.holdDyn 1 newPage + -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) + let headerAddPayment = R.never + tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + + result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) -> + flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do + table <- Table.view $ Table.In + { Table._in_users = _in_users input + , Table._in_currentUser = _in_currentUser input + , Table._in_categories = categories + , Table._in_currency = _in_currency input + , Table._in_payments = payments + , Table._in_paymentCategories = paymentCategories + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = p + } + + return ((), table, pages) + + return () return () -debounceSearchName - :: forall t m. MonadWidget t m - => Dynamic t Text - -> m (Event t Text, Dynamic t Text) -debounceSearchName searchName = do - event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) - dynamic <- R.holdDyn "" event - return (event, dynamic) - -reducePayments - :: forall t m. MonadWidget t m - => [Payment] - -> Event t Payment -- add payment - -> Event t Payment -- edit payment - -> Event t Payment -- delete payment - -> m (Dynamic t [Payment]) -reducePayments initPayments addPayment editPayment deletePayment = - R.foldDyn id initPayments $ R.leftmost - [ (:) <$> addPayment - , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) - , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) - ] - -reducePaymentCategories - :: forall t m. MonadWidget t m - => [PaymentCategory] - -> Dynamic t [Payment] -- payments - -> Event t PaymentCategory -- add payment category - -> Event t PaymentCategory -- edit payment category - -> Event t Payment -- delete payment - -> m (Dynamic t [PaymentCategory]) -reducePaymentCategories - initPaymentCategories - payments - addPaymentCategory - editPaymentCategory - deletePayment - = - R.foldDyn id initPaymentCategories $ R.leftmost - [ (:) <$> addPaymentCategory - , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) - , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) - ] - where - deletePaymentName = - R.attachWithMaybe - (\ps p -> - if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then - Nothing - else - Just (_payment_name p)) - (R.current payments) - deletePayment - lowerName = T.toLower . _payment_name - -getSearchPayments - :: forall t. Reflex t - => Dynamic t Text - -> Dynamic t Frequency - -> Dynamic t [Payment] - -> Dynamic t [Payment] -getSearchPayments name frequency payments = do - n <- name - f <- frequency - ps <- payments - pure $ flip filter ps (\p -> - ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) - && (_payment_frequency p == f) - )) + +-- view :: forall t m. MonadWidget t m => In t -> m () +-- view input = do +-- R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> +-- +-- R.elClass "main" "payment" $ do +-- rec +-- let addPayment = R.leftmost +-- -- [ Header._out_addPayment header +-- [ Table2._out_addPayment table +-- ] +-- +-- paymentsPerPage = 7 +-- +-- payments <- reducePayments +-- (_init_payments init) +-- (_savedPayment_payment <$> addPayment) +-- (_savedPayment_payment <$> Table2._out_editPayment table) +-- (Table2._out_deletePayment table) +-- +-- paymentCategories <- reducePaymentCategories +-- (_init_paymentCategories init) +-- payments +-- (_savedPayment_paymentCategory <$> addPayment) +-- (_savedPayment_paymentCategory <$> Table2._out_editPayment table) +-- (Table2._out_deletePayment table) +-- +-- -- (searchNameEvent, searchName) <- +-- -- debounceSearchName (Header._out_searchName header) +-- +-- -- let searchPayments = +-- -- getSearchPayments searchName (Header._out_searchFrequency header) payments +-- +-- -- header <- Header.view $ Header.In +-- -- { Header._in_init = init +-- -- , Header._in_currency = _in_currency input +-- -- , Header._in_payments = payments +-- -- , Header._in_searchPayments = searchPayments +-- -- , Header._in_paymentCategories = paymentCategories +-- -- } +-- +-- table <- Table2.view $ Table2.In +-- { Table2._in_init = init +-- , Table2._in_currency = _in_currency input +-- , Table2._in_currentUser = _in_currentUser input +-- , Table2._in_currentPage = Pages2._out_currentPage pages +-- , Table2._in_payments = payments +-- , Table2._in_perPage = paymentsPerPage +-- , Table2._in_paymentCategories = paymentCategories +-- } +-- +-- pages <- Pages2.view $ Pages2.In +-- { Pages2._in_total = length <$> payments +-- , Pages2._in_perPage = paymentsPerPage +-- , Pages2._in_reset = R.never +-- -- [ () <$ searchNameEvent +-- -- [ () <$ Header._out_addPayment header +-- -- ] +-- } +-- +-- pure () +-- +-- return () +-- +-- -- debounceSearchName +-- -- :: forall t m. MonadWidget t m +-- -- => Dynamic t Text +-- -- -> m (Event t Text, Dynamic t Text) +-- -- debounceSearchName searchName = do +-- -- event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) +-- -- dynamic <- R.holdDyn "" event +-- -- return (event, dynamic) +-- +-- reducePayments +-- :: forall t m. MonadWidget t m +-- => [Payment] +-- -> Event t Payment -- add payment +-- -> Event t Payment -- edit payment +-- -> Event t Payment -- delete payment +-- -> m (Dynamic t [Payment]) +-- reducePayments initPayments addPayment editPayment deletePayment = +-- R.foldDyn id initPayments $ R.leftmost +-- [ (:) <$> addPayment +-- , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) +-- , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) +-- ] +-- +-- reducePaymentCategories +-- :: forall t m. MonadWidget t m +-- => [PaymentCategory] +-- -> Dynamic t [Payment] -- payments +-- -> Event t PaymentCategory -- add payment category +-- -> Event t PaymentCategory -- edit payment category +-- -> Event t Payment -- delete payment +-- -> m (Dynamic t [PaymentCategory]) +-- reducePaymentCategories +-- initPaymentCategories +-- payments +-- addPaymentCategory +-- editPaymentCategory +-- deletePayment +-- = +-- R.foldDyn id initPaymentCategories $ R.leftmost +-- [ (:) <$> addPaymentCategory +-- , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) +-- , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) +-- ] +-- where +-- deletePaymentName = +-- R.attachWithMaybe +-- (\ps p -> +-- if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then +-- Nothing +-- else +-- Just (_payment_name p)) +-- (R.current payments) +-- deletePayment +-- lowerName = T.toLower . _payment_name +-- +-- -- getSearchPayments +-- -- :: forall t. Reflex t +-- -- => Dynamic t Text +-- -- -> Dynamic t Frequency +-- -- -> Dynamic t [Payment] +-- -- -> Dynamic t [Payment] +-- -- getSearchPayments name frequency payments = do +-- -- n <- name +-- -- f <- frequency +-- -- ps <- payments +-- -- pure $ flip filter ps (\p -> +-- -- ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) +-- -- && (_payment_frequency p == f) +-- -- )) -- cgit v1.2.3