From fc8be14dd0089eb12b78af7aaaecd8ed57896677 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 7 Aug 2019 21:27:59 +0200 Subject: Update category according to payment in add overlay --- client/src/Component/Select.hs | 8 +++++- client/src/Util/Validation.hs | 9 +++++-- client/src/View/Payment.hs | 1 + client/src/View/Payment/Add.hs | 33 ++++++++++++++++++----- client/src/View/Payment/Delete.hs | 9 ++++--- client/src/View/Payment/Header.hs | 15 +++++++---- client/src/View/Payment/Table.hs | 57 ++++++++++++++++++++++++++++----------- 7 files changed, 97 insertions(+), 35 deletions(-) (limited to 'client') diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 9f671d3..43a8a6e 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -16,6 +16,7 @@ import qualified Common.Msg as Msg data (Reflex t) => SelectIn t a b c = SelectIn { _selectIn_label :: Text , _selectIn_initialValue :: a + , _selectIn_value :: Event t a , _selectIn_values :: Dynamic t (Map a Text) , _selectIn_reset :: Event t b , _selectIn_isValid :: a -> Bool @@ -48,11 +49,16 @@ select selectIn = do let initialValue = _selectIn_initialValue selectIn + let setValue = R.leftmost + [ const initialValue <$> (_selectIn_reset selectIn) + , _selectIn_value selectIn + ] + value <- R._dropdown_value <$> R.dropdown initialValue (_selectIn_values selectIn) - (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) + (R.def { R._dropdownConfig_setValue = setValue }) errorMessage <- R.holdDyn "" $ R.attachWith (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!") diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs index e2a3dcb..fc13f36 100644 --- a/client/src/Util/Validation.hs +++ b/client/src/Util/Validation.hs @@ -1,7 +1,8 @@ module Util.Validation - ( fireValidation + ( nelError + , toMaybe + , fireValidation , fireMaybe - , nelError ) where import Control.Monad (join) @@ -16,6 +17,10 @@ import qualified Reflex.Dom as R nelError :: Validation a b -> Validation (NonEmpty a) b nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success +toMaybe :: Validation a b -> Maybe b +toMaybe (Success s) = Just s +toMaybe (Failure _) = Nothing + fireValidation :: forall t a b c. Reflex t => Dynamic t (Maybe (Validation a b)) diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f614936..05eedab 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -54,6 +54,7 @@ widget paymentIn = do header <- Header.widget $ HeaderIn { _headerIn_init = init , _headerIn_searchPayments = searchPayments + , _headerIn_paymentCategories = paymentCategories } table <- Table.widget $ TableIn diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 2970394..d023613 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -4,21 +4,26 @@ module View.Payment.Add , AddOut(..) ) where +import Control.Monad (join) import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L import qualified Data.Map as M import qualified Data.Maybe as Maybe +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time import qualified Data.Validation as V -import Reflex.Dom (Event, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import qualified Text.Read as T -import Common.Model (Category (..), CreatePayment (..), +import Common.Model (Category (..), CategoryId, + CreatePayment (..), CreatedPayment (..), Frequency (..), Payment (..), PaymentCategory (..)) import qualified Common.Msg as Msg +import qualified Common.Util.Text as Text import qualified Common.Util.Time as Time import qualified Common.Validation.Payment as PaymentValidation import Component (ButtonIn (..), InputIn (..), @@ -31,8 +36,9 @@ import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor data AddIn t = AddIn - { _addIn_categories :: [Category] - , _addIn_cancel :: Event t () + { _addIn_categories :: [Category] + , _addIn_paymentCategories :: Dynamic t [PaymentCategory] + , _addIn_cancel :: Event t () } data AddOut t = AddOut @@ -54,13 +60,13 @@ view addIn = do , const "" <$> _addIn_cancel addIn ] - name <- _inputOut_value <$> (Component.input + name <- Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name , _inputIn_validation = PaymentValidation.name }) reset - validate) + validate cost <- _inputOut_value <$> (Component.input (Component.defaultInputIn @@ -90,15 +96,22 @@ view addIn = do frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency , _selectIn_initialValue = Punctual + , _selectIn_value = R.never , _selectIn_values = R.constDyn frequencies , _selectIn_reset = reset , _selectIn_isValid = const True , _selectIn_validate = validate }) + let setCategory = + R.fmapMaybe id + . R.updated + $ findCategory <$> (_inputOut_raw name) <*> (_addIn_paymentCategories addIn) + category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category , _selectIn_initialValue = -1 + , _selectIn_value = setCategory , _selectIn_values = R.constDyn categories , _selectIn_reset = reset , _selectIn_isValid = \id -> id /= -1 @@ -106,7 +119,7 @@ view addIn = do }) let payment = do - n <- name + n <- _inputOut_value name c <- cost d <- date cat <- category @@ -154,3 +167,9 @@ view addIn = do categories = M.fromList . flip map (_addIn_categories addIn) $ \c -> (_category_id c, _category_name c) + + +findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId +findCategory paymentName = + fmap _paymentCategory_category + . L.find ((==) (Text.formatSearch paymentName) . _paymentCategory_name) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 81c7c57..4aa10f3 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -34,6 +34,11 @@ view deleteIn = R.divClass "deleteContent" $ do (deletedPayment, cancel) <- R.divClass "buttons" $ do + + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + rec confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -50,10 +55,6 @@ view deleteIn = (Ajax.delete url) confirm - 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 DeleteOut diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index c49b284..5cc362a 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -20,7 +20,8 @@ import qualified Reflex.Dom as R import Common.Model (Category, CreatedPayment (..), Currency, ExceedingPayer (..), Frequency (..), Income (..), Init (..), - Payment (..), User (..)) + Payment (..), PaymentCategory, + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -34,8 +35,9 @@ import View.Payment.Add (AddIn (..), AddOut (..)) import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn - { _headerIn_init :: Init - , _headerIn_searchPayments :: Dynamic t [Payment] + { _headerIn_init :: Init + , _headerIn_searchPayments :: Dynamic t [Payment] + , _headerIn_paymentCategories :: Dynamic t [PaymentCategory] } data HeaderOut t = HeaderOut @@ -47,7 +49,7 @@ data HeaderOut t = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - addPayment <- payerAndAdd incomes punctualPayments users categories currency + addPayment <- payerAndAdd incomes punctualPayments users categories paymentCategories currency let resetSearchName = fmap (const ()) $ addPayment (searchName, searchFrequency) <- searchLine resetSearchName @@ -66,6 +68,7 @@ widget headerIn = users = _init_users init categories = _init_categories init currency = _init_currency init + paymentCategories = _headerIn_paymentCategories headerIn payerAndAdd :: forall t m. MonadWidget t m @@ -73,9 +76,10 @@ payerAndAdd -> [Payment] -> [User] -> [Category] + -> Dynamic t [PaymentCategory] -> Currency -> m (Event t CreatedPayment) -payerAndAdd incomes payments users categories currency = do +payerAndAdd incomes payments users categories paymentCategories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do R.divClass "exceedingPayers" $ @@ -105,6 +109,7 @@ payerAndAdd incomes payments users categories currency = do ] , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories + , _addIn_paymentCategories = paymentCategories , _addIn_cancel = _modalOut_hide modalOut } } diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 6432274..cdc4bb3 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -26,7 +26,7 @@ import View.Payment.Delete (DeleteIn (..), DeleteOut (..)) import qualified View.Payment.Delete as Delete import qualified Icon -import qualified Util.Dom as Dom +import qualified Util.Dom as DomUtil data TableIn t = TableIn { _tableIn_init :: Init @@ -57,7 +57,7 @@ widget tableIn = do (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init paymentCategories)) - Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ + DomUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty return $ TableOut @@ -79,13 +79,24 @@ getPaymentRange perPage payments currentPage = . L.sortOn _payment_date $ payments -paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId) +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 - let user = flip fmap payment $ \p -> CM.findUser (_payment_user p) (_init_users init) + 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 + + let user = R.ffor payment (\p -> + CM.findUser (_payment_user p) (_init_users init)) + R.divClass "cell user" $ R.dynText $ flip fmap user $ \mbUser -> case mbUser of Just u -> _user_name u @@ -95,13 +106,16 @@ paymentRow init paymentCategories payment = 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 [ ("class", "tag") , ("style", T.concat [ "background-color: ", _category_color c ]) ] Nothing -> M.singleton "display" "none" + R.elDynAttr "span" attrs $ R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of Just c -> _category_name c @@ -110,15 +124,26 @@ paymentRow init paymentCategories payment = R.divClass "cell date" $ do R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment - R.divClass "cell button" . R.el "button" $ Icon.clone - let modifyAttrs = flip fmap payment $ \p -> - M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] - R.elDynAttr "div" modifyAttrs $ - R.el "button" $ Icon.edit - deletePayment <- R.elDynAttr "div" modifyAttrs $ - _buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn Icon.delete) - { _buttonIn_class = R.constDyn "deletePayment" }) + + R.divClass "cell button" $ + R.el "button" Icon.clone + + let isFromCurrentUser = + R.ffor + payment + (\p -> _payment_user p == _init_currentUser init) + + R.divClass "cell button" $ + DomUtil.divVisibleIf isFromCurrentUser $ + R.el "button" Icon.edit + + deletePayment <- + R.divClass "cell button" $ + DomUtil.divVisibleIf isFromCurrentUser $ + _buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn Icon.delete) + { _buttonIn_class = R.constDyn "deletePayment" }) + rec modalOut <- Component.modal $ ModalIn { _modalIn_show = deletePayment @@ -133,6 +158,6 @@ paymentRow init paymentCategories payment = findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do paymentCategory <- L.find - ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) + ((== T.formatSearch paymentName) . _paymentCategory_name) paymentCategories L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories -- cgit v1.2.3