aboutsummaryrefslogtreecommitdiff
path: root/client/src/View/Payment
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/View/Payment')
-rw-r--r--client/src/View/Payment/Payment.hs154
-rw-r--r--client/src/View/Payment/Table.hs3
2 files changed, 154 insertions, 3 deletions
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)
+ ))
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 40bc864..bf6b604 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -30,9 +30,6 @@ import qualified View.Payment.Edit as Edit
import qualified Icon
import qualified Util.Reflex as ReflexUtil
--- TODO: remove
-import Debug.Trace (trace)
-
data TableIn t = TableIn
{ _tableIn_init :: Init
, _tableIn_currentPage :: Dynamic t Int