diff options
Diffstat (limited to 'client/src/View/Payment/Add.hs')
| -rw-r--r-- | client/src/View/Payment/Add.hs | 127 |
1 files changed, 81 insertions, 46 deletions
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 061eeeb..62b26a3 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -4,31 +4,34 @@ module View.Payment.Add , AddOut(..) ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Map as M -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, Reflex) -import qualified Reflex.Dom as R -import qualified Text.Read as T - -import Common.Model (Category (..), CreatePayment (..), - Frequency (..), Payment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as Time -import Component (ButtonIn (..), InputIn (..), - InputOut (..), SelectIn (..), - SelectOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +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 qualified Data.Validation as V +import Reflex.Dom (Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CreatePayment (..), + Frequency (..), Payment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as Time +import qualified Common.Validation.Payment as PaymentValidation +import Component (ButtonIn (..), InputIn (..), + InputOut (..), SelectIn (..), + SelectOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor data AddIn t = AddIn { _addIn_categories :: [Category] - , _addIn_show :: Event t () + , _addIn_cancel :: Event t () } data AddOut t = AddOut @@ -43,48 +46,84 @@ view addIn = do R.divClass "addContent" $ do rec + let reset = R.leftmost + [ const "" <$> cancel + , const "" <$> addedPayment + , const "" <$> _addIn_cancel addIn + ] + name <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) - (const () <$ addedPayment)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Name + , _inputIn_validation = PaymentValidation.name + }) + reset + validate) cost <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) - (const () <$ addedPayment)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_validation = PaymentValidation.cost + }) + reset + validate) - currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + currentDay <- do + d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + return . T.pack . Calendar.showGregorian $ d date <- _inputOut_value <$> (Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay + , _inputIn_initialValue = currentDay , _inputIn_inputType = "date" , _inputIn_hasResetButton = False + , _inputIn_validation = PaymentValidation.date }) - (const () <$ addedPayment)) + (const currentDay <$> reset) + validate) 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 + , _selectIn_reset = reset + , _selectIn_isValid = const True + , _selectIn_validate = validate }) category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = 0 + , _selectIn_initialValue = -1 , _selectIn_values = R.constDyn categories - , _selectIn_reset = _addIn_show addIn + , _selectIn_reset = reset + , _selectIn_isValid = \id -> id /= -1 + , _selectIn_validate = validate }) - let payment = CreatePayment - <$> name - <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost - <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date - <*> category - <*> frequency - - (addedPayment, cancel) <- R.divClass "buttons" $ do + let payment = do + n <- name + c <- cost + 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) + + (addedPayment, cancel, validate) <- 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 $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" @@ -94,13 +133,9 @@ view addIn = do (result, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") - (R.tag (R.current payment) validate) - - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) + (ValidationUtil.fireValidation payment validate) - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate) return AddOut { _addOut_cancel = cancel |