From bc81084933f8ec1bfe6c2834defd12243117fdd9 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 5 Aug 2019 21:53:30 +0200 Subject: Use updated payment categories from payment add in payment’s table --- client/src/View/Payment/Add.hs | 22 +++++++++++++--------- client/src/View/Payment/Header.hs | 22 +++++++++++----------- client/src/View/Payment/Table.hs | 31 +++++++++++++++++-------------- 3 files changed, 41 insertions(+), 34 deletions(-) (limited to 'client/src/View/Payment') diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 62b26a3..2970394 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -16,7 +16,8 @@ import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CreatePayment (..), - Frequency (..), Payment (..)) + CreatedPayment (..), Frequency (..), + Payment (..), PaymentCategory (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as Time import qualified Common.Validation.Payment as PaymentValidation @@ -35,8 +36,9 @@ data AddIn t = AddIn } data AddOut t = AddOut - { _addOut_cancel :: Event t () - , _addOut_addedPayment :: Event t Payment + { _addOut_cancel :: Event t () + , _addOut_addPayment :: Event t CreatedPayment + , _addOut_addPaymentCategory :: Event t PaymentCategory } view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t) @@ -48,7 +50,7 @@ view addIn = do rec let reset = R.leftmost [ const "" <$> cancel - , const "" <$> addedPayment + , const "" <$> addPayment , const "" <$> _addIn_cancel addIn ] @@ -68,8 +70,10 @@ view addIn = do reset validate) + now <- liftIO Time.getCurrentTime + currentDay <- do - d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + d <- liftIO $ Time.timeToDay now return . T.pack . Calendar.showGregorian $ d date <- _inputOut_value <$> (Component.input @@ -118,7 +122,7 @@ view addIn = do <*> ValidationUtil.nelError (V.Success cat) <*> ValidationUtil.nelError (V.Success f) - (addedPayment, cancel, validate) <- R.divClass "buttons" $ do + (addPayment, cancel, validate) <- R.divClass "buttons" $ do rec cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) @@ -131,15 +135,15 @@ view addIn = do , _buttonIn_submit = True }) - (result, waiting) <- WaitFor.waitFor + (addPayment, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") (ValidationUtil.fireValidation payment validate) - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate) + return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate) return AddOut { _addOut_cancel = cancel - , _addOut_addedPayment = addedPayment + , _addOut_addPayment = addPayment } where diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 56441eb..c49b284 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -17,10 +17,10 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Category, Currency, - ExceedingPayer (..), Frequency (..), - Income (..), Init (..), Payment (..), - User (..)) +import Common.Model (Category, CreatedPayment (..), + Currency, ExceedingPayer (..), + Frequency (..), Income (..), Init (..), + Payment (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -41,14 +41,14 @@ data HeaderIn t = HeaderIn data HeaderOut t = HeaderOut { _headerOut_searchName :: Dynamic t Text , _headerOut_searchFrequency :: Dynamic t Frequency - , _headerOut_addedPayment :: Event t Payment + , _headerOut_addPayment :: Event t CreatedPayment } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - addedPayment <- payerAndAdd incomes punctualPayments users categories currency - let resetSearchName = fmap (const ()) $ addedPayment + addPayment <- payerAndAdd incomes punctualPayments users categories currency + let resetSearchName = fmap (const ()) $ addPayment (searchName, searchFrequency) <- searchLine resetSearchName infos (_headerIn_searchPayments headerIn) users currency @@ -56,7 +56,7 @@ widget headerIn = return $ HeaderOut { _headerOut_searchName = searchName , _headerOut_searchFrequency = searchFrequency - , _headerOut_addedPayment = addedPayment + , _headerOut_addPayment = addPayment } where init = _headerIn_init headerIn @@ -74,7 +74,7 @@ payerAndAdd -> [User] -> [Category] -> Currency - -> m (Event t Payment) + -> m (Event t CreatedPayment) payerAndAdd incomes payments users categories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -101,7 +101,7 @@ payerAndAdd incomes payments users categories currency = do { _modalIn_show = addPaymentClic , _modalIn_hide = R.leftmost $ [ _addOut_cancel addOut - , fmap (const ()) . _addOut_addedPayment $ addOut + , fmap (const ()) . _addOut_addPayment $ addOut ] , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories @@ -109,7 +109,7 @@ payerAndAdd incomes payments users categories currency = do } } let addOut = _modalOut_content modalOut - return (_addOut_addedPayment addOut) + return (_addOut_addPayment addOut) searchLine :: forall t m. MonadWidget t m diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index ba16bf5..6432274 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -29,21 +29,22 @@ import qualified Icon import qualified Util.Dom as Dom data TableIn t = TableIn - { _tableIn_init :: Init - , _tableIn_currentPage :: Dynamic t Int - , _tableIn_payments :: Dynamic t [Payment] - , _tableIn_perPage :: Int + { _tableIn_init :: Init + , _tableIn_currentPage :: Dynamic t Int + , _tableIn_payments :: Dynamic t [Payment] + , _tableIn_perPage :: Int + , _tableIn_paymentCategories :: Dynamic t [PaymentCategory] } data TableOut t = TableOut - { _tableOut_deletedPayment :: Event t PaymentId + { _tableOut_deletePayment :: Event t PaymentId } widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - deletedPayment <- R.divClass "lines" $ do + deletePayment <- R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost @@ -53,13 +54,14 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init)) + (R.switch . R.current . fmap R.leftmost) <$> + (R.simpleList paymentRange (paymentRow init paymentCategories)) Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty return $ TableOut - { _tableOut_deletedPayment = deletedPayment + { _tableOut_deletePayment = deletePayment } where @@ -67,6 +69,7 @@ widget tableIn = do currentPage = _tableIn_currentPage tableIn payments = _tableIn_payments tableIn paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage + paymentCategories = _tableIn_paymentCategories tableIn getPaymentRange :: Int -> [Payment] -> Int -> [Payment] getPaymentRange perPage payments currentPage = @@ -76,8 +79,8 @@ getPaymentRange perPage payments currentPage = . L.sortOn _payment_date $ payments -paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId) -paymentRow init payment = +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId) +paymentRow init paymentCategories payment = R.divClass "row" $ do R.divClass "cell name" . R.dynText . fmap _payment_name $ payment R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $ payment @@ -88,10 +91,10 @@ paymentRow init payment = Just u -> _user_name u _ -> "" - let category = flip fmap payment $ \p -> findCategory - (_init_categories init) - (_init_paymentCategories init) - (_payment_name p) + let category = do + p <- payment + pcs <- paymentCategories + return $ findCategory (_init_categories init) pcs (_payment_name p) R.divClass "cell category" $ do let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of Just c -> M.fromList -- cgit v1.2.3