Show the payment table with server side paging

1 files changed, 202 insertions, 165 deletions

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)
+-- --     ))