aboutsummaryrefslogtreecommitdiff
path: root/client/src
diff options
context:
space:
mode:
Diffstat (limited to 'client/src')
-rw-r--r--client/src/Component/Input.hs69
-rw-r--r--client/src/Component/Select.hs54
-rw-r--r--client/src/Util/Validation.hs9
-rw-r--r--client/src/View/Payment.hs1
-rw-r--r--client/src/View/Payment/Add.hs36
-rw-r--r--client/src/View/Payment/Header.hs34
6 files changed, 121 insertions, 82 deletions
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index d679f9b..abdc51c 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -40,7 +40,7 @@ defaultInputIn = InputIn
data InputOut t a = InputOut
{ _inputOut_raw :: Dynamic t Text
- , _inputOut_value :: Dynamic t (Maybe (Validation Text a))
+ , _inputOut_value :: Dynamic t (Validation Text a)
, _inputOut_enter :: Event t ()
}
@@ -64,27 +64,14 @@ input inputIn reset validate = do
value = R._textInput_value textInput
- containerAttr = R.ffor validatedValue (\v ->
+ containerAttr = R.ffor inputError (\e ->
M.singleton "class" $ T.intercalate " "
[ "textInput"
- , if Maybe.fromMaybe False (ValidationUtil.isFailure <$> v) then "error" else ""
+ , if Maybe.isJust e then "error" else ""
])
- -- Clear validation errors after reset
- delayedReset <- R.delay (0.1 :: NominalDiffTime) reset
-
- validatedValue <- R.holdDyn Nothing $ R.attachWith
- (\v (clearValidation, validateEmpty) ->
- if clearValidation
- then Nothing
- else Just (_inputIn_validation inputIn $ (if validateEmpty then "" else v)))
- (R.current value)
- (R.leftmost
- [ const (False, True) <$> resetClic
- , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput)
- , const (False, False) <$> validate
- , const (True, False) <$> delayedReset
- ])
+ let valueWithValidation = R.ffor value (\v -> (v, _inputIn_validation inputIn $ v))
+ inputError <- getInputError valueWithValidation validate
(textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
@@ -108,7 +95,7 @@ input inputIn reset validate = do
return R.never
R.divClass "errorMessage" $
- R.dynText . fmap validationError $ validatedValue
+ R.dynText . fmap (Maybe.fromMaybe "") $ inputError
return (textInput, resetClic)
@@ -116,10 +103,46 @@ input inputIn reset validate = do
return $ InputOut
{ _inputOut_raw = value
- , _inputOut_value = validatedValue
+ , _inputOut_value = fmap snd valueWithValidation
, _inputOut_enter = enter
}
-validationError :: Maybe (Validation Text a) -> Text
-validationError (Just (Failure e)) = e
-validationError _ = ""
+getInputError
+ :: forall t m a b c. MonadWidget t m
+ => Dynamic t (Text, Validation Text a)
+ -> Event t c
+ -> m (Dynamic t (Maybe Text))
+getInputError validatedValue validate = do
+ let errorDynamic = fmap (\(t, v) -> (t, validationError v)) validatedValue
+ errorEvent = R.updated errorDynamic
+ delayedError <- R.debounce (1 :: NominalDiffTime) errorEvent
+ fmap (fmap fst) $ R.foldDyn
+ (\event (err, hasBeenResetted) ->
+ case event of
+ ModifiedEvent t ->
+ (Nothing, T.null t)
+
+ ValidateEvent e ->
+ (e, False)
+
+ DelayEvent e ->
+ if hasBeenResetted then
+ (Nothing, False)
+ else
+ (e, False)
+ )
+ (Nothing, False)
+ (R.leftmost
+ [ fmap (\(t, _) -> ModifiedEvent t) errorEvent
+ , fmap (\(_, e) -> DelayEvent e) delayedError
+ , R.attachWith (\(_, e) _ -> ValidateEvent e) (R.current errorDynamic) validate
+ ])
+
+validationError :: (Validation Text a) -> Maybe Text
+validationError (Failure e) = Just e
+validationError _ = Nothing
+
+data InputEvent
+ = ModifiedEvent Text
+ | DelayEvent (Maybe Text)
+ | ValidateEvent (Maybe Text)
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 43a8a6e..01ed37a 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -4,14 +4,17 @@ module Component.Select
, select
) where
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Text (Text)
-import qualified Data.Text as T
-import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
-import qualified Reflex.Dom as R
+import Data.Map (Map)
+import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Validation (Validation (Failure, Success))
+import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
+import qualified Reflex.Dom as R
-import qualified Common.Msg as Msg
+import qualified Common.Msg as Msg
+import qualified Util.Validation as ValidationUtil
data (Reflex t) => SelectIn t a b c = SelectIn
{ _selectIn_label :: Text
@@ -24,25 +27,33 @@ data (Reflex t) => SelectIn t a b c = SelectIn
}
data SelectOut t a = SelectOut
- { _selectOut_value :: Dynamic t a
+ { _selectOut_value :: Dynamic t (Validation Text a)
}
select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a)
select selectIn = do
rec
- let containerAttr = R.ffor hasError (\e ->
+ let containerAttr = R.ffor showedError (\e ->
M.singleton "class" $ T.intercalate " "
[ "selectInput"
- , if e then "error" else ""
+ , if Maybe.isJust e then "error" else ""
])
- hasError <- R.holdDyn False $ R.attachWith
- (\v clearError -> not clearError && not (_selectIn_isValid selectIn v))
- (R.current value)
- (R.leftmost
- [ const False <$> _selectIn_validate selectIn
- , const True <$> _selectIn_reset selectIn
- ])
+ validatedValue =
+ R.ffor value (\v ->
+ if _selectIn_isValid selectIn v then
+ Success v
+ else
+ Failure (Msg.get Msg.Form_NonEmpty))
+
+ maybeError =
+ fmap ValidationUtil.maybeError validatedValue
+
+ showedError <- R.holdDyn Nothing $ R.leftmost
+ [ const Nothing <$> _selectIn_reset selectIn
+ , R.updated maybeError
+ , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn)
+ ]
value <- R.elDynAttr "div" containerAttr $ do
R.el "label" $ R.text (_selectIn_label selectIn)
@@ -60,16 +71,11 @@ select selectIn = do
(_selectIn_values selectIn)
(R.def { R._dropdownConfig_setValue = setValue })
- errorMessage <- R.holdDyn "" $ R.attachWith
- (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!")
- (R.current value)
- (_selectIn_validate selectIn)
-
R.divClass "errorMessage" . R.dynText $
- R.ffor hasError (\e -> if e then Msg.get Msg.Form_NonEmpty else "")
+ R.ffor showedError (Maybe.fromMaybe "")
return value
return SelectOut
- { _selectOut_value = value
+ { _selectOut_value = validatedValue
}
diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index fc13f36..f9545a4 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -1,6 +1,7 @@
module Util.Validation
( nelError
, toMaybe
+ , maybeError
, fireValidation
, fireMaybe
) where
@@ -21,14 +22,18 @@ toMaybe :: Validation a b -> Maybe b
toMaybe (Success s) = Just s
toMaybe (Failure _) = Nothing
+maybeError :: Validation a b -> Maybe a
+maybeError (Success _) = Nothing
+maybeError (Failure e) = Just e
+
fireValidation
:: forall t a b c. Reflex t
- => Dynamic t (Maybe (Validation a b))
+ => Dynamic t (Validation a b)
-> Event t c
-> Event t b
fireValidation value validate =
R.fmapMaybe
- (join . fmap (Validation.validation (const Nothing) Just))
+ (Validation.validation (const Nothing) Just)
(R.tag (R.current value) validate)
fireMaybe
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 05eedab..ae20079 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -53,6 +53,7 @@ widget paymentIn = do
header <- Header.widget $ HeaderIn
{ _headerIn_init = init
+ , _headerIn_payments = payments
, _headerIn_searchPayments = searchPayments
, _headerIn_paymentCategories = paymentCategories
}
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index d023613..e0772f7 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -66,7 +66,7 @@ view addIn = do
, _inputIn_validation = PaymentValidation.name
})
reset
- validate
+ confirm
cost <- _inputOut_value <$> (Component.input
(Component.defaultInputIn
@@ -74,7 +74,7 @@ view addIn = do
, _inputIn_validation = PaymentValidation.cost
})
reset
- validate)
+ confirm)
now <- liftIO Time.getCurrentTime
@@ -91,7 +91,7 @@ view addIn = do
, _inputIn_validation = PaymentValidation.date
})
(const currentDay <$> reset)
- validate)
+ confirm)
frequency <- _selectOut_value <$> (Component.select $ SelectIn
{ _selectIn_label = Msg.get Msg.Payment_Frequency
@@ -100,7 +100,7 @@ view addIn = do
, _selectIn_values = R.constDyn frequencies
, _selectIn_reset = reset
, _selectIn_isValid = const True
- , _selectIn_validate = validate
+ , _selectIn_validate = confirm
})
let setCategory =
@@ -115,7 +115,7 @@ view addIn = do
, _selectIn_values = R.constDyn categories
, _selectIn_reset = reset
, _selectIn_isValid = \id -> id /= -1
- , _selectIn_validate = validate
+ , _selectIn_validate = confirm
})
let payment = do
@@ -124,24 +124,20 @@ view addIn = do
d <- date
cat <- category
f <- frequency
- pure $ do
- n' <- n
- c' <- c
- d' <- d
- pure $ CreatePayment
- <$> ValidationUtil.nelError n'
- <*> ValidationUtil.nelError c'
- <*> ValidationUtil.nelError d'
- <*> ValidationUtil.nelError (V.Success cat)
- <*> ValidationUtil.nelError (V.Success f)
-
- (addPayment, cancel, validate) <- R.divClass "buttons" $ do
+ return (CreatePayment
+ <$> ValidationUtil.nelError n
+ <*> ValidationUtil.nelError c
+ <*> ValidationUtil.nelError d
+ <*> ValidationUtil.nelError cat
+ <*> ValidationUtil.nelError f)
+
+ (addPayment, cancel, confirm) <- R.divClass "buttons" $ do
rec
cancel <- Component._buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
{ _buttonIn_class = R.constDyn "undo" })
- validate <- Component._buttonOut_clic <$> (Component.button $
+ confirm <- Component._buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
{ _buttonIn_class = R.constDyn "confirm"
, _buttonIn_waiting = waiting
@@ -150,9 +146,9 @@ view addIn = do
(addPayment, waiting) <- WaitFor.waitFor
(Ajax.postJson "/payment")
- (ValidationUtil.fireValidation payment validate)
+ (ValidationUtil.fireValidation payment confirm)
- return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate)
+ return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
return AddOut
{ _addOut_cancel = cancel
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 5cc362a..73517f0 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -36,6 +36,7 @@ import qualified View.Payment.Add as Add
data HeaderIn t = HeaderIn
{ _headerIn_init :: Init
+ , _headerIn_payments :: Dynamic t [Payment]
, _headerIn_searchPayments :: Dynamic t [Payment]
, _headerIn_paymentCategories :: Dynamic t [PaymentCategory]
}
@@ -49,7 +50,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 paymentCategories currency
+ addPayment <- payerAndAdd incomes payments users categories paymentCategories currency
let resetSearchName = fmap (const ()) $ addPayment
(searchName, searchFrequency) <- searchLine resetSearchName
@@ -64,7 +65,7 @@ widget headerIn =
init = _headerIn_init headerIn
incomes = _init_incomes init
initPayments = _init_payments init
- punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments
+ payments = _headerIn_payments headerIn
users = _init_users init
categories = _init_categories init
currency = _init_currency init
@@ -73,7 +74,7 @@ widget headerIn =
payerAndAdd
:: forall t m. MonadWidget t m
=> [Income]
- -> [Payment]
+ -> Dynamic t [Payment]
-> [User]
-> [Category]
-> Dynamic t [PaymentCategory]
@@ -82,17 +83,23 @@ payerAndAdd
payerAndAdd incomes payments users categories paymentCategories currency = do
time <- liftIO Time.getCurrentTime
R.divClass "payerAndAdd" $ do
+
+ let exceedingPayers =
+ R.ffor payments $ \ps ->
+ CM.getExceedingPayers time users incomes $
+ filter ((==) Punctual . _payment_frequency) ps
+
R.divClass "exceedingPayers" $
- forM_
- (CM.getExceedingPayers time users incomes payments)
- (\p ->
- R.elClass "span" "exceedingPayer" $ do
- R.elClass "span" "userName" $
- R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users
- R.elClass "span" "amount" $ do
- R.text "+ "
- R.text . Format.price currency $ _exceedingPayer_amount p
- )
+ R.simpleList exceedingPayers $ \exceedingPayer ->
+ R.elClass "span" "exceedingPayer" $ do
+ R.elClass "span" "userName" $
+ R.dynText . R.ffor exceedingPayer $ \ep ->
+ fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users
+ R.elClass "span" "amount" $ do
+ R.text "+ "
+ R.dynText . R.ffor exceedingPayer $ \ep ->
+ Format.price currency $ _exceedingPayer_amount ep
+
addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn
{ _buttonIn_class = R.constDyn "addPayment"
, _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
@@ -100,6 +107,7 @@ payerAndAdd incomes payments users categories paymentCategories currency = do
, _buttonIn_tabIndex = Nothing
, _buttonIn_submit = False
})
+
rec
modalOut <- Component.modal $ ModalIn
{ _modalIn_show = addPaymentClic
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 00:34:07 +0000