aboutsummaryrefslogtreecommitdiff
path: root/client
diff options
context:
space:
mode:
Diffstat (limited to 'client')
-rw-r--r--client/src/Component/Select.hs8
-rw-r--r--client/src/Util/Validation.hs9
-rw-r--r--client/src/View/Payment.hs1
-rw-r--r--client/src/View/Payment/Add.hs33
-rw-r--r--client/src/View/Payment/Delete.hs9
-rw-r--r--client/src/View/Payment/Header.hs15
-rw-r--r--client/src/View/Payment/Table.hs57
7 files changed, 97 insertions, 35 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:23:07 +0000