diff options
Diffstat (limited to 'client/src/View/Payment/Add.hs')
| -rw-r--r-- | client/src/View/Payment/Add.hs | 187 |
1 files changed, 40 insertions, 147 deletions
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 69e29a7..88806bc 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -1,161 +1,54 @@ module View.Payment.Add ( view - , AddIn(..) - , AddOut(..) + , Input(..) ) 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 (Dynamic, Event, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import qualified Text.Read as T -import Common.Model (Category (..), CategoryId, - CreatePayment (..), - CreatedPayment (..), Frequency (..), - Payment (..), PaymentCategory (..)) +import Common.Model (Category (..), CreatePayment (..), + Frequency (..), Payment (..), + PaymentCategory (..), + SavedPayment (..)) import qualified Common.Msg as Msg -import qualified Common.Util.Time as Time +import qualified Common.Util.Time as TimeUtil 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_paymentCategories :: Dynamic t [PaymentCategory] - , _addIn_frequency :: Dynamic t Frequency - , _addIn_cancel :: Event t () - } - -data AddOut t = AddOut - { _addOut_cancel :: Event t () - , _addOut_addPayment :: Event t CreatedPayment - , _addOut_addPaymentCategory :: Event t PaymentCategory +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form + +data Input t = Input + { _input_categories :: [Category] + , _input_paymentCategories :: Dynamic t [PaymentCategory] + , _input_frequency :: Dynamic t Frequency } -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 - rec - let reset = R.leftmost - [ "" <$ cancel - , "" <$ addPayment - , "" <$ _addIn_cancel addIn - ] - - name <- Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Name - , _inputIn_validation = PaymentValidation.name - }) - reset - confirm - - cost <- _inputOut_value <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Cost - , _inputIn_validation = PaymentValidation.cost - }) - reset - confirm) - - now <- liftIO Time.getCurrentTime - - currentDay <- do - d <- liftIO $ Time.timeToDay now - return . T.pack . Calendar.showGregorian $ d - - date <- _inputOut_value <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = currentDay - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = PaymentValidation.date - }) - (currentDay <$ reset) - confirm) - - 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 - , _selectIn_validate = confirm - }) - - let payment = do - n <- _inputOut_value name - c <- cost - d <- date - cat <- category - f <- _addIn_frequency addIn - return (CreatePayment - <$> ValidationUtil.nelError n - <*> ValidationUtil.nelError c - <*> ValidationUtil.nelError d - <*> ValidationUtil.nelError cat - <*> V.Success 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" }) - - confirm <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True - }) - - (addPayment, waiting) <- WaitFor.waitFor - (Ajax.postJson "/payment") - (ValidationUtil.fireValidation payment confirm) - - return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) - - return AddOut - { _addOut_cancel = cancel - , _addOut_addPayment = addPayment - } - - where - frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] - - 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 ((==) (T.toLower paymentName) . _paymentCategory_name) +view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view input cancel = do + + currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay + + formOutput <- R.dyn $ do + paymentCategories <- _input_paymentCategories input + frequency <- _input_frequency input + return $ Form.view $ Form.Input + { Form._input_cancel = cancel + , Form._input_headerLabel = Msg.get Msg.Payment_Add + , Form._input_categories = _input_categories input + , Form._input_paymentCategories = paymentCategories + , Form._input_name = "" + , Form._input_cost = "" + , Form._input_date = currentDay + , Form._input_category = -1 + , Form._input_frequency = frequency + , Form._input_mkPayload = CreatePayment + } + + hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) + addPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) + + return (hide, addPayment) |