From 04c59f08f100ba6a0658d1f2b357f7d8b1e14218 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 13 Oct 2019 22:38:35 +0200
Subject: Show income table

---
 client/src/View/Payment/Payment.hs | 154 +++++++++++++++++++++++++++++++++++++
 1 file changed, 154 insertions(+)
 create mode 100644 client/src/View/Payment/Payment.hs

(limited to 'client/src/View/Payment/Payment.hs')

diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
new file mode 100644
index 0000000..cfdb441
--- /dev/null
+++ b/client/src/View/Payment/Payment.hs
@@ -0,0 +1,154 @@
+module View.Payment.Payment
+  ( view
+  , PaymentIn(..)
+  ) 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        (Frequency, Init (..), Payment (..),
+                                      PaymentCategory (..), PaymentId,
+                                      SavedPayment (..))
+import qualified Common.Util.Text    as T
+import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
+import qualified View.Payment.Header as Header
+import           View.Payment.Pages  (PagesIn (..), PagesOut (..))
+import qualified View.Payment.Pages  as Pages
+import           View.Payment.Table  (TableIn (..), TableOut (..))
+import qualified View.Payment.Table  as Table
+
+data PaymentIn = PaymentIn
+  { _paymentIn_init :: Init
+  }
+
+view :: forall t m. MonadWidget t m => PaymentIn -> m ()
+view paymentIn = do
+  R.elClass "main" "payment" $ do
+    rec
+      let init = _paymentIn_init paymentIn
+
+          paymentsPerPage = 7
+
+          addPayment = R.leftmost
+            [ _headerOut_addPayment header
+            , _tableOut_addPayment table
+            ]
+
+      payments <- reducePayments
+        (_init_payments init)
+        (_savedPayment_payment <$> addPayment)
+        (_savedPayment_payment <$> _tableOut_editPayment table)
+        (_tableOut_deletePayment table)
+
+      paymentCategories <- reducePaymentCategories
+        (_init_paymentCategories init)
+        payments
+        (_savedPayment_paymentCategory <$> addPayment)
+        (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
+        (_tableOut_deletePayment table)
+
+      (searchNameEvent, searchName) <-
+        debounceSearchName (_headerOut_searchName header)
+
+      let searchPayments =
+            getSearchPayments searchName (_headerOut_searchFrequency header) payments
+
+      header <- Header.widget $ HeaderIn
+        { _headerIn_init = init
+        , _headerIn_payments = payments
+        , _headerIn_searchPayments = searchPayments
+        , _headerIn_paymentCategories = paymentCategories
+        }
+
+      table <- Table.widget $ TableIn
+        { _tableIn_init = init
+        , _tableIn_currentPage = _pagesOut_currentPage pages
+        , _tableIn_payments = searchPayments
+        , _tableIn_perPage = paymentsPerPage
+        , _tableIn_paymentCategories = paymentCategories
+        }
+
+      pages <- Pages.widget $ PagesIn
+        { _pagesIn_total = length <$> searchPayments
+        , _pagesIn_perPage = paymentsPerPage
+        , _pagesIn_reset = R.leftmost $
+            [ () <$ searchNameEvent
+            , () <$ _headerOut_addPayment header
+            ]
+        }
+
+    pure ()
+
+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