From 50fb8fa48d1c4881da20b4ecf6d68a772301e713 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 18:04:58 +0100 Subject: Update table when adding or removing a payment --- client/src/View/Payment/Add.hs | 39 ++++++++++++------- client/src/View/Payment/Delete.hs | 13 +++++-- client/src/View/Payment/Header.hs | 79 +++++++++++++++++++++++---------------- client/src/View/Payment/Pages.hs | 2 +- client/src/View/Payment/Table.hs | 29 ++++++++------ 5 files changed, 99 insertions(+), 63 deletions(-) (limited to 'client/src/View/Payment') diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 8b1b56e..602f7f3 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -10,12 +10,12 @@ import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time -import Reflex.Dom (Event, MonadWidget) +import Reflex.Dom (Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CreatePayment (..), - Frequency (..)) + Frequency (..), Payment (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as Time import Component (ButtonIn (..), InputIn (..), @@ -23,48 +23,56 @@ import Component (ButtonIn (..), InputIn (..), SelectOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor -data AddIn = AddIn +data AddIn t = AddIn { _addIn_categories :: [Category] + , _addIn_show :: Event t () } data AddOut t = AddOut - { _addOut_cancel :: Event t () + { _addOut_cancel :: Event t () + , _addOut_addedPayment :: Event t Payment } -view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t) +view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t) view addIn = do R.divClass "add" $ do R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add R.divClass "addContent" $ do - name <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + name <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + (_addIn_show addIn)) - cost <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + cost <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + (_addIn_show addIn)) currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay - date <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn + date <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Date , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay , _inputIn_inputType = "date" , _inputIn_hasResetButton = False }) + (_addIn_show addIn)) frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency , _selectIn_initialValue = Punctual , _selectIn_values = R.constDyn frequencies + , _selectIn_reset = _addIn_show addIn }) category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category , _selectIn_initialValue = 0 , _selectIn_values = R.constDyn categories + , _selectIn_reset = _addIn_show addIn }) let payment = CreatePayment @@ -74,7 +82,7 @@ view addIn = do <*> category <*> frequency - cancel <- R.divClass "buttons" $ do + (addedPayment, cancel) <- R.divClass "buttons" $ do rec validate <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -83,17 +91,20 @@ view addIn = do , _buttonIn_submit = True }) - (_, waiting) <- WaitFor.waitFor + (result, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") validate payment - Component._buttonOut_clic <$> (Component.button $ + cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) { _buttonIn_class = R.constDyn "undo" }) + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) + return AddOut { _addOut_cancel = cancel + , _addOut_addedPayment = addedPayment } where diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 03cf267..330ef9f 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -4,6 +4,7 @@ module View.Payment.Delete , DeleteOut(..) ) where +import Data.Text (Text) import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R @@ -13,6 +14,7 @@ import qualified Common.Msg as Msg import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil -- import qualified Util.WaitFor as WaitFor data DeleteIn t = DeleteIn @@ -20,7 +22,8 @@ data DeleteIn t = DeleteIn } data DeleteOut t = DeleteOut - { _deleteOut_cancel :: Event t () + { _deleteOut_cancel :: Event t () + , _deleteOut_validate :: Event t PaymentId } view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) @@ -30,7 +33,7 @@ view deleteIn = R.divClass "deleteContent" $ do - cancel <- R.divClass "buttons" $ do + (deletedPayment, cancel) <- R.divClass "buttons" $ do rec confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -41,7 +44,8 @@ view deleteIn = let url = flip fmap (_deleteIn_id deleteIn) (\id -> T.concat ["/payment/", T.pack . show $ id] ) - Ajax.delete url confirm + + result <- Ajax.delete url confirm -- (_, waiting) <- WaitFor.waitFor -- (Ajax.delete "/payment") @@ -52,8 +56,9 @@ view deleteIn = (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) { _buttonIn_class = R.constDyn "undo" }) - return cancel + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) return DeleteOut { _deleteOut_cancel = cancel + , _deleteOut_validate = R.tag (R.current $ _deleteIn_id deleteIn) deletedPayment } diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index be7f6d5..653df5e 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -13,7 +13,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import Common.Model (Category, Currency, @@ -22,7 +22,6 @@ import Common.Model (Category, Currency, User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg -import qualified Common.Util.Text as T import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), @@ -34,44 +33,47 @@ import View.Payment.Add (AddIn (..), AddOut (..)) import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn - { _headerIn_init :: Init + { _headerIn_init :: Init + , _headerIn_searchPayments :: Dynamic t [Payment] } data HeaderOut t = HeaderOut - { _headerOut_searchName :: Dynamic t Text - , _headerOut_searchPayments :: Dynamic t [Payment] + { _headerOut_searchName :: Dynamic t Text + , _headerOut_searchFrequency :: Dynamic t Frequency + , _headerOut_addedPayment :: Event t Payment } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - payerAndAdd incomes punctualPayments users categories currency - (searchName, searchFrequency) <- searchLine - let searchPayments = getSearchPayments searchName searchFrequency payments - infos searchPayments users currency + addedPayment <- payerAndAdd incomes punctualPayments users categories currency + let resetSearchName = fmap (const ()) $ addedPayment + (searchName, searchFrequency) <- searchLine resetSearchName + + infos (_headerIn_searchPayments headerIn) users currency + return $ HeaderOut { _headerOut_searchName = searchName - , _headerOut_searchPayments = searchPayments + , _headerOut_searchFrequency = searchFrequency + , _headerOut_addedPayment = addedPayment } where init = _headerIn_init headerIn incomes = _init_incomes init - payments = _init_payments init - punctualPayments = filter ((==) Punctual . _payment_frequency) payments + initPayments = _init_payments init + punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments users = _init_users init categories = _init_categories init currency = _init_currency init -getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment] -getSearchPayments name frequency payments = do - n <- name - f <- frequency - pure $ flip filter payments (\p -> - ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) - && (_payment_frequency p == f) - )) - -payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m () +payerAndAdd + :: forall t m. MonadWidget t m + => [Income] + -> [Payment] + -> [User] + -> [Category] + -> Currency + -> m (Event t Payment) payerAndAdd incomes payments users categories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -94,19 +96,28 @@ payerAndAdd incomes payments users categories currency = do , _buttonIn_submit = False }) rec - modalOut <- Component.modal $ ModalIn + modalOut <- fmap _modalOut_content . Component.modal $ ModalIn { _modalIn_show = addPaymentClic - , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut - , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories } + , _modalIn_hide = R.leftmost $ + [ _addOut_cancel modalOut + , fmap (const ()) . _addOut_addedPayment $ modalOut + ] + , _modalIn_content = Add.view $ AddIn + { _addIn_categories = categories + , _addIn_show = addPaymentClic + } } - return () + return (_addOut_addedPayment modalOut) -searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) -searchLine = do +searchLine + :: forall t m. MonadWidget t m + => Event t () + -> m (Dynamic t Text, Dynamic t Frequency) +searchLine reset = do R.divClass "searchLine" $ do - searchName <- _inputOut_value <$> (Component.input $ Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Search_Name - }) + searchName <- _inputOut_value <$> (Component.input + ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) + reset) let frequencies = M.fromList [ (Punctual, Msg.get Msg.Payment_PunctualMale) @@ -118,7 +129,11 @@ searchLine = do return (searchName, searchFrequency) -infos :: forall t m. MonadWidget t m => Dynamic t [Payment] -> [User] -> Currency -> m () +infos + :: forall t m. MonadWidget t m + => Dynamic t [Payment] + -> [User] + -> Currency -> m () infos payments users currency = R.divClass "infos" $ do diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index d14b640..57d67ac 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -64,7 +64,7 @@ pageButtons total perPage reset = do return currentPage where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) - pageEvent = R.switchPromptlyDyn . fmap R.leftmost + pageEvent = R.switch . R.current . fmap R.leftmost noCurrentPage = R.constDyn Nothing range :: Int -> Int -> [Int] diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 13cedda..ba16bf5 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -9,11 +9,12 @@ import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) + PaymentCategory (..), PaymentId, + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.Util.Text as T @@ -34,15 +35,15 @@ data TableIn t = TableIn , _tableIn_perPage :: Int } -data TableOut = TableOut - { +data TableOut t = TableOut + { _tableOut_deletedPayment :: Event t PaymentId } -widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut +widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - R.divClass "lines" $ do + deletedPayment <- 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 @@ -52,13 +53,14 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - _ <- R.simpleList paymentRange (paymentRow init) - return () + (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init)) Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty - return $ TableOut {} + return $ TableOut + { _tableOut_deletedPayment = deletedPayment + } where init = _tableIn_init tableIn @@ -74,7 +76,7 @@ getPaymentRange perPage payments currentPage = . L.sortOn _payment_date $ payments -paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId) paymentRow init payment = R.divClass "row" $ do R.divClass "cell name" . R.dynText . fmap _payment_name $ payment @@ -117,10 +119,13 @@ paymentRow init payment = rec modalOut <- Component.modal $ ModalIn { _modalIn_show = deletePayment - , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut + , _modalIn_hide = R.leftmost $ + [ _deleteOut_cancel . _modalOut_content $ modalOut + , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut + ] , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment }) } - return () + return (_deleteOut_validate . _modalOut_content $ modalOut) findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do -- cgit v1.2.3