aboutsummaryrefslogtreecommitdiff
path: root/client
diff options
context:
space:
mode:
authorJoris2019-11-17 18:08:28 +0100
committerJoris2019-11-17 18:08:28 +0100
commitc0ea63f8c1a8c7123b78798cec99726b113fb1f3 (patch)
tree0b92f7e0c125c067a5f1ccafe6a1f04f1edfae86 /client
parent4dc84dbda7ba3ea60d13e6f81eeec556974b7c72 (diff)
Optimize and refactor payments
Diffstat (limited to 'client')
-rw-r--r--client/src/Loadable.hs3
-rw-r--r--client/src/Util/Ajax.hs5
-rw-r--r--client/src/Util/Either.hs2
-rw-r--r--client/src/Util/List.hs13
-rw-r--r--client/src/View/Payment/Form.hs52
-rw-r--r--client/src/View/Payment/HeaderForm.hs69
-rw-r--r--client/src/View/Payment/HeaderInfos.hs28
-rw-r--r--client/src/View/Payment/Payment.hs177
-rw-r--r--client/src/View/Payment/Reducer.hs83
-rw-r--r--client/src/View/Payment/Table.hs31
10 files changed, 183 insertions, 280 deletions
diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs
index f57b99c..2b9008a 100644
--- a/client/src/Loadable.hs
+++ b/client/src/Loadable.hs
@@ -16,6 +16,7 @@ data Loadable t
= Loading
| Error Text
| Loaded t
+ deriving Show
instance Functor Loadable where
fmap f Loading = Loading
@@ -46,6 +47,6 @@ fromEvent =
Loading
view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b)
-view _ (Loading) = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing
+view _ Loading = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing
view _ (Error e) = R.text e >> return Nothing
view f (Loaded x) = Just <$> f x
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 47f4f3c..dc56701 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -16,6 +16,7 @@ import qualified Data.Map.Lazy as LM
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
+import Data.Time.Clock (NominalDiffTime)
import Reflex.Dom (Dynamic, Event, IsXhrPayload,
MonadWidget, XhrRequest,
XhrRequestConfig (..), XhrResponse,
@@ -28,7 +29,9 @@ import qualified Loadable
getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a))
getNow url = do
postBuild <- R.getPostBuild
- get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent
+ get (url <$ postBuild)
+ >>= R.debounce (0 :: NominalDiffTime) -- Fired 2 times otherwise
+ >>= Loadable.fromEvent
get
:: forall t m a. (MonadWidget t m, FromJSON a)
diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs
index 2910d95..e76bc8a 100644
--- a/client/src/Util/Either.hs
+++ b/client/src/Util/Either.hs
@@ -2,6 +2,6 @@ module Util.Either
( eitherToMaybe
) where
-eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe :: forall a b. Either a b -> Maybe b
eitherToMaybe (Right b) = Just b
eitherToMaybe _ = Nothing
diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs
deleted file mode 100644
index 4e22ba8..0000000
--- a/client/src/Util/List.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Util.List
- ( groupBy
- ) where
-
-import Control.Arrow ((&&&))
-import Data.Function (on)
-import qualified Data.List as L
-
-groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])]
-groupBy f =
- map (f . head &&& id)
- . L.groupBy ((==) `on` f)
- . L.sortBy (compare `on` f)
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 99b0848..6c3c1e8 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -4,6 +4,7 @@ module View.Payment.Form
, Operation(..)
) where
+import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (Value)
import qualified Data.Aeson as Aeson
@@ -13,6 +14,7 @@ import qualified Data.Map as M
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Time (NominalDiffTime)
import Data.Time.Calendar (Day)
import qualified Data.Time.Calendar as Calendar
import qualified Data.Time.Clock as Clock
@@ -25,9 +27,7 @@ import qualified Text.Read as T
import Common.Model (Category (..), CategoryId,
CreatePaymentForm (..),
EditPaymentForm (..),
- Frequency (..), Payment (..),
- PaymentCategory (..),
- SavedPayment (..))
+ Frequency (..), Payment (..))
import qualified Common.Msg as Msg
import qualified Common.Util.Time as TimeUtil
import qualified Common.Validation.Payment as PaymentValidation
@@ -37,20 +37,20 @@ import qualified Component.Modal as Modal
import qualified Component.ModalForm as ModalForm
import qualified Component.Select as Select
import qualified Util.Ajax as Ajax
+import qualified Util.Either as EitherUtil
import qualified Util.Validation as ValidationUtil
-data In = In
- { _in_categories :: [Category]
- , _in_paymentCategories :: [PaymentCategory]
- , _in_operation :: Operation
+data In t = In
+ { _in_categories :: [Category]
+ , _in_operation :: Operation t
}
-data Operation
- = New Frequency
+data Operation t
+ = New (Dynamic t Frequency)
| Clone Payment
| Edit Payment
-view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment
+view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment
view input cancel = do
rec
let reset = R.leftmost
@@ -105,9 +105,10 @@ view input cancel = do
(d <$ reset)
confirm)
- let setCategory =
- R.fmapMaybe id . R.updated $
- R.ffor (Input._out_raw name) findCategory
+ setCategory <-
+ R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name)
+ >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>)))
+ >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe))
category <- Select._out_value <$> (Select.view $ Select.In
{ Select._in_label = Msg.get Msg.Payment_Category
@@ -124,12 +125,13 @@ view input cancel = do
c <- cost
d <- date
cat <- category
+ f <- frequency
return (mkPayload
<$> ValidationUtil.nelError n
<*> V.Success c
<*> V.Success d
<*> ValidationUtil.nelError cat
- <*> V.Success frequency)
+ <*> V.Success f)
frequencies =
M.fromList
@@ -140,6 +142,12 @@ view input cancel = do
categories = M.fromList . flip map (_in_categories input) $ \c ->
(_category_id c, _category_name c)
+ category =
+ case op of
+ New _ -> -1
+ Clone p -> _payment_category p
+ Edit p -> _payment_category p
+
op = _in_operation input
name =
@@ -162,17 +170,11 @@ view input cancel = do
Clone p -> currentDay
Edit p -> _payment_date p
- category =
- case op of
- New _ -> -1
- Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p)
- Edit p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p)
-
frequency =
case op of
New f -> f
- Clone p -> _payment_frequency p
- Edit p -> _payment_frequency p
+ Clone p -> R.constDyn $ _payment_frequency p
+ Edit p -> R.constDyn $ _payment_frequency p
headerLabel =
case op of
@@ -189,9 +191,3 @@ view input cancel = do
case op of
Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e
_ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e
-
- findCategory :: Text -> Maybe CategoryId
- findCategory paymentName =
- fmap _paymentCategory_category
- . L.find ((==) (T.toLower paymentName) . _paymentCategory_name)
- $ (_in_paymentCategories input)
diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs
index 07a6b81..c8ca4d9 100644
--- a/client/src/View/Payment/HeaderForm.hs
+++ b/client/src/View/Payment/HeaderForm.hs
@@ -1,5 +1,7 @@
module View.Payment.HeaderForm
( view
+ , In(..)
+ , Out(..)
) where
import qualified Data.Map as M
@@ -8,10 +10,8 @@ import qualified Data.Validation as V
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
-import Common.Model (Category, Currency, ExceedingPayer (..),
- Frequency (..), Income (..), Payment (..),
- PaymentCategory, SavedPayment (..),
- User (..))
+import Common.Model (Category, Currency, Frequency (..),
+ Income (..), Payment (..), User (..))
import qualified Common.Msg as Msg
import qualified Component.Button as Button
@@ -21,39 +21,43 @@ import qualified Component.Select as Select
import qualified View.Payment.Form as Form
data In t = In
- { _in_reset :: Event t ()
- , _in_categories :: [Category]
- , _in_paymentCategories :: [PaymentCategory]
+ { _in_reset :: Event t ()
+ , _in_categories :: [Category]
}
-data Out = Out
- { _out_name :: Event t Text
+data Out t = Out
+ { _out_search :: Event t Text
, _out_frequency :: Event t Frequency
- , _out_addPayment :: Event t SavedPayment
+ , _out_addPayment :: Event t Payment
}
view :: forall t m. MonadWidget t m => In t -> m (Out t)
-view input = do
- R.divClass "g-HeaderForm" $ do
- searchName <- Input._out_raw <$> (Input.view
- ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
- ("" <$ _in_reset input)
- R.never)
+view input =
+ R.divClass "g-PaymentHeaderForm" $ do
- let frequencies = M.fromList
- [ (Punctual, Msg.get Msg.Payment_PunctualMale)
- , (Monthly, Msg.get Msg.Payment_MonthlyMale)
- ]
+ (searchName, frequency) <- R.el "div" $ do
- searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
- { Select._in_label = ""
- , Select._in_initialValue = Punctual
- , Select._in_value = R.never
- , Select._in_values = R.constDyn frequencies
- , Select._in_reset = R.never
- , Select._in_isValid = V.Success
- , Select._in_validate = R.never
- })
+ searchName <- Input._out_raw <$> (Input.view
+ ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
+ ("" <$ _in_reset input)
+ R.never)
+
+ let frequencies = M.fromList
+ [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+ , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+ ]
+
+ frequency <- Select._out_raw <$> (Select.view $ Select.In
+ { Select._in_label = ""
+ , Select._in_initialValue = Punctual
+ , Select._in_value = R.never
+ , Select._in_values = R.constDyn frequencies
+ , Select._in_reset = R.never
+ , Select._in_isValid = V.Success
+ , Select._in_validate = R.never
+ })
+
+ return (searchName, frequency)
addPaymentButton <- Button._out_clic <$>
(Button.view $
@@ -66,13 +70,12 @@ view input = do
, Modal._in_content =
Form.view $ Form.In
{ Form._in_categories = _in_categories input
- , Form._in_paymentCategories = _in_paymentCategories input
- , Form._in_operation = Form.New searchFrequency
+ , Form._in_operation = Form.New frequency
}
}
return $ Out
- { _out_name = searchName
- , _out_frequency = searchFrequency
+ { _out_search = R.updated searchName
+ , _out_frequency = R.updated frequency
, _out_addPayment = addPayment
}
diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs
index 12facc4..f84ee1f 100644
--- a/client/src/View/Payment/HeaderInfos.hs
+++ b/client/src/View/Payment/HeaderInfos.hs
@@ -16,13 +16,11 @@ import qualified Reflex.Dom as R
import Common.Model (Currency, ExceedingPayer (..),
Payment (..), PaymentHeader (..),
- SavedPayment (..), User (..), UserId)
+ 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
-
data In t = In
{ _in_users :: [User]
, _in_currency :: Currency
@@ -32,17 +30,17 @@ data In t = In
view :: forall t m. MonadWidget t m => In t -> m ()
view input =
- R.divClass "g-HeaderInfos" $ do
- exceedingPayers
- (_in_users input)
- (_in_currency input)
- (_paymentHeader_exceedingPayers header)
+ R.divClass "g-PaymentHeaderInfos" $ do
+ exceedingPayers
+ (_in_users input)
+ (_in_currency input)
+ (_paymentHeader_exceedingPayers header)
- infos
- (_in_users input)
- (_in_currency input)
- (_paymentHeader_repartition header)
- (_in_paymentCount input)
+ infos
+ (_in_users input)
+ (_in_currency input)
+ (_paymentHeader_repartition header)
+ (_in_paymentCount input)
where
header = _in_header input
@@ -54,7 +52,7 @@ exceedingPayers
-> [ExceedingPayer]
-> m ()
exceedingPayers users currency payers =
- R.divClass "g-HeaderInfos__ExceedingPayers" $
+ R.divClass "g-PaymentHeaderInfos__ExceedingPayers" $
flip mapM_ payers $ \payer ->
R.elClass "span" "exceedingPayer" $ do
R.elClass "span" "userName" $
@@ -72,7 +70,7 @@ infos
-> Int
-> m ()
infos users currency repartition paymentCount =
- R.divClass "g-HeaderInfos__Repartition" $ do
+ R.divClass "g-PaymentHeaderInfos__Repartition" $ do
R.elClass "span" "total" $ do
R.text $
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index f47b627..6bc1614 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -3,6 +3,7 @@ module View.Payment.Payment
, In(..)
) where
+import Control.Monad.IO.Class (liftIO)
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
@@ -12,9 +13,8 @@ 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)
+ Payment (..), PaymentId,
+ PaymentPage (..), User, UserId)
import qualified Common.Util.Text as T
import qualified Component.Pages as Pages
@@ -22,8 +22,8 @@ import Loadable (Loadable (..))
import qualified Loadable
import qualified Util.Ajax as AjaxUtil
import qualified Util.Reflex as ReflexUtil
+import qualified View.Payment.HeaderForm as HeaderForm
import qualified View.Payment.HeaderInfos as HeaderInfos
--- import qualified View.Payment.HeaderForm as HeaderForm
import qualified View.Payment.Reducer as Reducer
import qualified View.Payment.Table as Table
@@ -36,15 +36,16 @@ data In t = In
view :: forall t m. MonadWidget t m => In t -> m ()
view input = do
- categoriesEvent <- (AjaxUtil.getNow "api/categories")
+ categories <- AjaxUtil.getNow "api/categories"
- R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do
+ R.dyn . R.ffor categories . 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_page = page
+ , Reducer._in_search = HeaderForm._out_search form
+ , Reducer._in_frequency = HeaderForm._out_frequency form
+ , Reducer._in_addPayment = addPayment
, Reducer._in_editPayment = editPayment
, Reducer._in_deletePayment = deletePayment
}
@@ -52,16 +53,25 @@ view input = do
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
+ let addPayment =
+ R.leftmost
+ [ tableAddPayment
+ , HeaderForm._out_addPayment form
+ ]
+
+ page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
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 header payments paymentCategories count) -> do
+ form <- HeaderForm.view $ HeaderForm.In
+ { HeaderForm._in_reset = () <$ addPayment
+ , HeaderForm._in_categories = categories
+ }
+
+ result <- R.dyn . R.ffor payments $
+ Loadable.view $ \(PaymentPage page header payments count) -> do
+
HeaderInfos.view $ HeaderInfos.In
{ HeaderInfos._in_users = _in_users input
, HeaderInfos._in_currency = _in_currency input
@@ -75,13 +85,12 @@ view input = do
, 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
+ , Pages._in_page = page
}
return ((), table, pages)
@@ -89,137 +98,3 @@ view input = do
return ()
return ()
-
-
--- 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)
--- -- ))
diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs
index 0c70f8a..0b6c041 100644
--- a/client/src/View/Payment/Reducer.hs
+++ b/client/src/View/Payment/Reducer.hs
@@ -2,14 +2,16 @@ module View.Payment.Reducer
( perPage
, reducer
, In(..)
+ , Params(..)
) where
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Time (NominalDiffTime)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
-import Common.Model (PaymentPage)
+import Common.Model (Frequency (..), PaymentPage)
import Loadable (Loadable (..))
import qualified Loadable as Loadable
@@ -19,48 +21,99 @@ perPage :: Int
perPage = 7
data In t a b c = In
- { _in_newPage :: Event t Int
- , _in_currentPage :: Dynamic t Int
+ { _in_page :: Event t Int
+ , _in_search :: Event t Text
+ , _in_frequency :: Event t Frequency
, _in_addPayment :: Event t a
, _in_editPayment :: Event t b
, _in_deletePayment :: Event t c
}
data Action
- = LoadPage Int
+ = LoadPage
| GetResult (Either Text PaymentPage)
+data Params = Params
+ { _params_page :: Int
+ , _params_search :: Text
+ , _params_frequency :: Frequency
+ } deriving (Show)
+
+initParams = Params 1 "" Punctual
+
+data Msg
+ = Page Int
+ | Search Text
+ | Frequency Common.Model.Frequency
+ | ResetSearch
+ deriving Show
+
reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage))
reducer input = do
postBuild <- R.getPostBuild
- let loadPage =
+ debouncedSearch <- R.debounce (1 :: NominalDiffTime) (_in_search input)
+
+ params <- R.foldDynMaybe
+ (\msg params -> case msg of
+ Page page ->
+ Just $ params { _params_page = page }
+
+ Search "" ->
+ if _params_search params == "" then
+ Nothing
+
+ else
+ Just $ initParams { _params_frequency = _params_frequency params }
+
+ Search search ->
+ Just $ params { _params_search = search, _params_page = _params_page initParams }
+
+ Frequency frequency ->
+ Just $ params { _params_frequency = frequency }
+
+ ResetSearch ->
+ Just $ initParams { _params_frequency = _params_frequency params }
+ )
+ initParams
+ (R.leftmost
+ [ Page <$> _in_page input
+ , Search <$> debouncedSearch
+ , Frequency <$> _in_frequency input
+ , ResetSearch <$ _in_addPayment input
+ ])
+
+ let paramsEvent =
R.leftmost
- [ 1 <$ postBuild
- , _in_newPage input
- , 1 <$ _in_addPayment input
- , R.tag (R.current $ _in_currentPage input) (_in_editPayment input)
- , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input)
+ [ initParams <$ postBuild
+ , R.updated params
+ , R.tag (R.current params) (_in_editPayment input)
+ , R.tag (R.current params) (_in_deletePayment input)
]
- getResult <- AjaxUtil.get $ fmap pageUrl loadPage
+ getResult <- AjaxUtil.get (pageUrl <$> paramsEvent)
+
R.foldDyn
(\action _ -> case action of
- LoadPage _ -> Loading
+ LoadPage -> Loading
GetResult (Left err) -> Error err
GetResult (Right payments) -> Loaded payments
)
Loading
(R.leftmost
- [ LoadPage <$> loadPage
+ [ LoadPage <$ paramsEvent
, GetResult <$> getResult
])
where
- pageUrl p =
+ pageUrl (Params page search frequency) =
"api/payments?page="
- <> (T.pack . show $ p)
+ <> (T.pack . show $ page)
<> "&perPage="
<> (T.pack . show $ perPage)
+ <> "&search="
+ <> search
+ <> "&frequency="
+ <> (T.pack $ show frequency)
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index dde5168..59ac890 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -13,7 +13,6 @@ import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Category (..), Currency, Payment (..),
- PaymentCategory (..), SavedPayment,
User (..), UserId)
import qualified Common.Model as CM
import qualified Common.Msg as Msg
@@ -26,17 +25,16 @@ import qualified Util.Either as EitherUtil
import qualified View.Payment.Form as Form
data In t = In
- { _in_users :: [User]
- , _in_currentUser :: UserId
- , _in_categories :: [Category]
- , _in_currency :: Currency
- , _in_payments :: [Payment]
- , _in_paymentCategories :: [PaymentCategory]
+ { _in_users :: [User]
+ , _in_currentUser :: UserId
+ , _in_categories :: [Category]
+ , _in_currency :: Currency
+ , _in_payments :: [Payment]
}
data Out t = Out
- { _out_add :: Event t SavedPayment
- , _out_edit :: Event t SavedPayment
+ { _out_add :: Event t Payment
+ , _out_edit :: Event t Payment
, _out_delete :: Event t Payment
}
@@ -50,18 +48,15 @@ view input = do
cell
(_in_users input)
(_in_categories input)
- (_in_paymentCategories input)
(_in_currency input)
, Table._in_cloneModal = \payment ->
Form.view $ Form.In
{ Form._in_categories = _in_categories input
- , Form._in_paymentCategories = _in_paymentCategories input
, Form._in_operation = Form.Clone payment
}
, Table._in_editModal = \payment ->
Form.view $ Form.In
{ Form._in_categories = _in_categories input
- , Form._in_paymentCategories = _in_paymentCategories input
, Form._in_operation = Form.Edit payment
}
, Table._in_deleteModal = \payment ->
@@ -101,12 +96,11 @@ cell
:: forall t m. MonadWidget t m
=> [User]
-> [Category]
- -> [PaymentCategory]
-> Currency
-> Header
-> Payment
-> m ()
-cell users categories paymentCategories currency header payment =
+cell users categories currency header payment =
case header of
NameHeader ->
R.text $ _payment_name payment
@@ -120,7 +114,7 @@ cell users categories paymentCategories currency header payment =
CategoryHeader ->
let
category =
- findCategory categories paymentCategories (_payment_name payment)
+ L.find ((== (_payment_category payment)) . _category_id) categories
attrs =
case category of
@@ -144,10 +138,3 @@ cell users categories paymentCategories currency header payment =
R.elClass "span" "longDate" $
R.text . Format.longDay . _payment_date $ payment
-
-findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
-findCategory categories paymentCategories paymentName = do
- paymentCategory <- L.find
- ((== T.toLower paymentName) . _paymentCategory_name)
- paymentCategories
- L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories