aboutsummaryrefslogtreecommitdiff
path: root/client/src
diff options
context:
space:
mode:
Diffstat (limited to 'client/src')
-rw-r--r--client/src/Component.hs15
-rw-r--r--client/src/Component/ModalForm.hs70
-rw-r--r--client/src/View/Income/Add.hs3
-rw-r--r--client/src/View/Income/Form.hs138
-rw-r--r--client/src/View/Payment/Add.hs3
-rw-r--r--client/src/View/Payment/Clone.hs3
-rw-r--r--client/src/View/Payment/Edit.hs3
-rw-r--r--client/src/View/Payment/Form.hs205
8 files changed, 233 insertions, 207 deletions
diff --git a/client/src/Component.hs b/client/src/Component.hs
index b715a83..fa4e4ea 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -1,9 +1,10 @@
module Component (module X) where
-import Component.Button as X
-import Component.Form as X
-import Component.Input as X
-import Component.Link as X
-import Component.Pages as X
-import Component.Select as X
-import Component.Table as X
+import Component.Button as X
+import Component.Form as X
+import Component.Input as X
+import Component.Link as X
+import Component.ModalForm as X
+import Component.Pages as X
+import Component.Select as X
+import Component.Table as X
diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs
new file mode 100644
index 0000000..63cb1d2
--- /dev/null
+++ b/client/src/Component/ModalForm.hs
@@ -0,0 +1,70 @@
+module Component.ModalForm
+ ( modalForm
+ , ModalFormIn(..)
+ , ModalFormOut(..)
+ ) where
+
+import Data.Aeson (ToJSON)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Calendar (Day)
+import Data.Validation (Validation)
+import qualified Data.Validation as V
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Msg as Msg
+import Component.Button (ButtonIn (..))
+import qualified Component.Button as Button
+import qualified Util.Either as EitherUtil
+import qualified Util.Validation as ValidationUtil
+import qualified Util.WaitFor as WaitFor
+
+data ModalFormIn m t a b e = ModalFormIn
+ { _modalFormIn_headerLabel :: Text
+ , _modalFormIn_form :: m (Dynamic t (Validation e a))
+ , _modalFormIn_ajax :: Event t a -> m (Event t (Either Text b))
+ }
+
+data ModalFormOut t a = ModalFormOut
+ { _modalFormOut_hide :: Event t ()
+ , _modalFormOut_cancel :: Event t ()
+ , _modalFormOut_confirm :: Event t ()
+ , _modalFormOut_validate :: Event t a
+ }
+
+modalForm :: forall t m a b e. (MonadWidget t m, ToJSON a) => ModalFormIn m t a b e -> m (ModalFormOut t b)
+modalForm modalFormIn =
+ R.divClass "form" $ do
+ R.divClass "formHeader" $
+ R.text (_modalFormIn_headerLabel modalFormIn)
+
+ R.divClass "formContent" $ do
+ rec
+ form <- _modalFormIn_form modalFormIn
+
+ (validate, cancel, confirm) <- R.divClass "buttons" $ do
+ rec
+ cancel <- Button._buttonOut_clic <$> (Button.button $
+ (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+ { _buttonIn_class = R.constDyn "undo" })
+
+ confirm <- Button._buttonOut_clic <$> (Button.button $
+ (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+ { _buttonIn_class = R.constDyn "confirm"
+ , _buttonIn_waiting = waiting
+ , _buttonIn_submit = True
+ })
+
+ (validate, waiting) <- WaitFor.waitFor
+ (_modalFormIn_ajax modalFormIn)
+ (ValidationUtil.fireValidation form confirm)
+
+ return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm)
+
+ return ModalFormOut
+ { _modalFormOut_hide = R.leftmost [ cancel, () <$ validate ]
+ , _modalFormOut_cancel = cancel
+ , _modalFormOut_confirm = confirm
+ , _modalFormOut_validate = validate
+ }
diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs
index d83bb51..0b1bd04 100644
--- a/client/src/View/Income/Add.hs
+++ b/client/src/View/Income/Add.hs
@@ -11,6 +11,7 @@ import Common.Model (CreateIncomeForm (..), Income)
import qualified Common.Msg as Msg
import qualified Common.Util.Time as TimeUtil
import qualified Component.Modal as Modal
+import qualified Util.Ajax as Ajax
import qualified Util.Reflex as ReflexUtil
import View.Income.Form (FormIn (..), FormOut (..))
import qualified View.Income.Form as Form
@@ -27,7 +28,7 @@ view cancel = do
, _formIn_amount = ""
, _formIn_date = currentDay
, _formIn_mkPayload = CreateIncomeForm
- , _formIn_httpMethod = Form.Post
+ , _formIn_ajax = Ajax.post
}
hide <- ReflexUtil.flatten (_formOut_hide <$> form)
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
index 2bfc23f..824bb0a 100644
--- a/client/src/View/Income/Form.hs
+++ b/client/src/View/Income/Form.hs
@@ -1,113 +1,89 @@
module View.Income.Form
( view
, FormIn(..)
- , HttpMethod(..)
, FormOut(..)
) where
-import Data.Aeson (ToJSON)
+import Data.Aeson (FromJSON, ToJSON)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import qualified Data.Time.Calendar as Calendar
+import Data.Validation (Validation)
import qualified Data.Validation as V
-import Reflex.Dom (Event, MonadWidget)
+import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Income)
import qualified Common.Msg as Msg
import qualified Common.Validation.Income as IncomeValidation
-import Component (ButtonIn (..), InputIn (..),
- InputOut (..))
+import Component (InputIn (..), InputOut (..),
+ ModalFormIn (..), ModalFormOut (..))
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 FormIn t i = FormIn
+data FormIn m t a = FormIn
{ _formIn_cancel :: Event t ()
, _formIn_headerLabel :: Text
, _formIn_amount :: Text
, _formIn_date :: Day
- , _formIn_mkPayload :: Text -> Text -> i
- , _formIn_httpMethod :: HttpMethod
+ , _formIn_mkPayload :: Text -> Text -> a
+ , _formIn_ajax :: Text -> Event t a -> m (Event t (Either Text Income))
}
-data HttpMethod = Put | Post
-
data FormOut t = FormOut
{ _formOut_hide :: Event t ()
, _formOut_addIncome :: Event t Income
}
-view :: forall t m i. (MonadWidget t m, ToJSON i) => FormIn t i -> m (FormOut t)
+view :: forall t m a. (MonadWidget t m, ToJSON a) => FormIn m t a -> m (FormOut t)
view formIn = do
- R.divClass "form" $ do
- R.divClass "formHeader" $
- R.text (_formIn_headerLabel formIn)
-
- R.divClass "formContent" $ do
- rec
- let reset = R.leftmost
- [ "" <$ cancel
- , "" <$ addIncome
- , "" <$ _formIn_cancel formIn
- ]
-
- amount <- _inputOut_raw <$> (Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Income_Amount
- , _inputIn_initialValue = _formIn_amount formIn
- , _inputIn_validation = IncomeValidation.amount
- })
- (_formIn_amount formIn <$ reset)
- confirm)
-
- let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn
-
- date <- _inputOut_raw <$> (Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Income_Date
- , _inputIn_initialValue = initialDate
- , _inputIn_inputType = "date"
- , _inputIn_hasResetButton = False
- , _inputIn_validation = IncomeValidation.date
- })
- (initialDate <$ reset)
- confirm)
-
- let income = do
- a <- amount
- d <- date
- return . V.Success $ (_formIn_mkPayload formIn) a d
-
- (addIncome, 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
- })
-
- (addIncome, waiting) <- WaitFor.waitFor
- (ajax "/api/income")
- (ValidationUtil.fireValidation income confirm)
-
- return (R.fmapMaybe EitherUtil.eitherToMaybe addIncome, cancel, confirm)
-
- return FormOut
- { _formOut_hide = R.leftmost [ cancel, () <$ addIncome ]
- , _formOut_addIncome = addIncome
- }
+ rec
+ let reset = R.leftmost
+ [ "" <$ _modalFormOut_cancel modalForm
+ , "" <$ _modalFormOut_validate modalForm
+ , "" <$ _formIn_cancel formIn
+ ]
+
+ modalForm <- Component.modalForm $ ModalFormIn
+ { _modalFormIn_headerLabel = _formIn_headerLabel formIn
+ , _modalFormIn_ajax = _formIn_ajax formIn "/api/income"
+ , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm)
+ }
+
+ return $ FormOut
+ { _formOut_hide = _modalFormOut_hide modalForm
+ , _formOut_addIncome = _modalFormOut_validate modalForm
+ }
where
- ajax =
- case _formIn_httpMethod formIn of
- Post -> Ajax.post
- Put -> Ajax.put
+ form
+ :: Event t String
+ -> Event t ()
+ -> m (Dynamic t (Validation Text a))
+ form reset confirm = do
+ amount <- _inputOut_raw <$> (Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Income_Amount
+ , _inputIn_initialValue = _formIn_amount formIn
+ , _inputIn_validation = IncomeValidation.amount
+ })
+ (_formIn_amount formIn <$ reset)
+ confirm)
+
+ let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn
+
+ date <- _inputOut_raw <$> (Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Income_Date
+ , _inputIn_initialValue = initialDate
+ , _inputIn_inputType = "date"
+ , _inputIn_hasResetButton = False
+ , _inputIn_validation = IncomeValidation.date
+ })
+ (initialDate <$ reset)
+ confirm)
+
+ return $ do
+ a <- amount
+ d <- date
+ return . V.Success $ (_formIn_mkPayload formIn) a d
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 28c0148..163a200 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -17,6 +17,7 @@ import Common.Model (Category (..), CreatePaymentForm (..),
import qualified Common.Msg as Msg
import qualified Common.Util.Time as TimeUtil
import qualified Component.Modal as Modal
+import qualified Util.Ajax as Ajax
import qualified Util.Reflex as ReflexUtil
import qualified View.Payment.Form as Form
@@ -45,7 +46,7 @@ view input cancel = do
, Form._input_category = -1
, Form._input_frequency = frequency
, Form._input_mkPayload = CreatePaymentForm
- , Form._input_httpMethod = Form.Post
+ , Form._input_ajax = Ajax.post
}
hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
index 60694ca..2fa27f3 100644
--- a/client/src/View/Payment/Clone.hs
+++ b/client/src/View/Payment/Clone.hs
@@ -17,6 +17,7 @@ import Common.Model (Category (..), CategoryId,
import qualified Common.Msg as Msg
import qualified Common.Util.Time as TimeUtil
import qualified Component.Modal as Modal
+import qualified Util.Ajax as Ajax
import qualified Util.Reflex as ReflexUtil
import qualified View.Payment.Form as Form
@@ -48,7 +49,7 @@ view input cancel = do
, Form._input_category = category
, Form._input_frequency = _payment_frequency payment
, Form._input_mkPayload = CreatePaymentForm
- , Form._input_httpMethod = Form.Post
+ , Form._input_ajax = Ajax.post
}
hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
index 0361602..77841ce 100644
--- a/client/src/View/Payment/Edit.hs
+++ b/client/src/View/Payment/Edit.hs
@@ -14,6 +14,7 @@ import Common.Model (Category (..), CategoryId,
SavedPayment (..))
import qualified Common.Msg as Msg
import qualified Component.Modal as Modal
+import qualified Util.Ajax as Ajax
import qualified Util.Reflex as ReflexUtil
import qualified View.Payment.Form as Form
@@ -43,7 +44,7 @@ view input cancel = do
, Form._input_category = category
, Form._input_frequency = _payment_frequency payment
, Form._input_mkPayload = EditPaymentForm (_payment_id payment)
- , Form._input_httpMethod = Form.Put
+ , Form._input_ajax = Ajax.put
}
hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index c817831..1f068fd 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -1,23 +1,21 @@
module View.Payment.Form
( view
, Input(..)
- , HttpMethod(..)
, Output(..)
) where
-import Control.Monad (join)
-import Control.Monad.IO.Class (liftIO)
import Data.Aeson (ToJSON)
import qualified Data.List as L
+import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as M
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import qualified Data.Time.Calendar as Calendar
+import Data.Validation (Validation)
import qualified Data.Validation as V
-import Reflex.Dom (Dynamic, Event, MonadHold,
- MonadWidget, Reflex)
+import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import qualified Text.Read as T
@@ -27,16 +25,13 @@ import Common.Model (Category (..), CategoryId,
SavedPayment (..))
import qualified Common.Msg as Msg
import qualified Common.Validation.Payment as PaymentValidation
-import Component (ButtonIn (..), InputIn (..),
- InputOut (..), SelectIn (..),
- SelectOut (..))
+import Component (InputIn (..), InputOut (..),
+ ModalFormIn (..), ModalFormOut (..),
+ 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 Input t p = Input
+data Input m t a = Input
{ _input_cancel :: Event t ()
, _input_headerLabel :: Text
, _input_categories :: [Category]
@@ -46,114 +41,99 @@ data Input t p = Input
, _input_date :: Day
, _input_category :: CategoryId
, _input_frequency :: Frequency
- , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> p
- , _input_httpMethod :: HttpMethod
+ , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a
+ , _input_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment))
}
-data HttpMethod = Put | Post
-
data Output t = Output
{ _output_hide :: Event t ()
, _output_addPayment :: Event t SavedPayment
}
-view :: forall t m p. (MonadWidget t m, ToJSON p) => Input t p -> m (Output t)
+view :: forall t m a. (MonadWidget t m, ToJSON a) => Input m t a -> m (Output t)
view input = do
- R.divClass "form" $ do
- R.divClass "formHeader" $
- R.text (_input_headerLabel input)
-
- R.divClass "formContent" $ do
- rec
- let reset = R.leftmost
- [ "" <$ cancel
- , "" <$ addPayment
- , "" <$ _input_cancel input
- ]
-
- name <- Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Payment_Name
- , _inputIn_initialValue = _input_name input
- , _inputIn_validation = PaymentValidation.name
- })
- (_input_name input <$ reset)
- confirm
-
- cost <- _inputOut_raw <$> (Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Payment_Cost
- , _inputIn_initialValue = _input_cost input
- , _inputIn_validation = PaymentValidation.cost
- })
- (_input_cost input <$ reset)
- confirm)
-
- let initialDate = T.pack . Calendar.showGregorian . _input_date $ input
-
- date <- _inputOut_raw <$> (Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Payment_Date
- , _inputIn_initialValue = initialDate
- , _inputIn_inputType = "date"
- , _inputIn_hasResetButton = False
- , _inputIn_validation = PaymentValidation.date
- })
- (initialDate <$ reset)
- confirm)
-
- let setCategory =
- R.fmapMaybe id . R.updated $
- R.ffor (_inputOut_raw name) $ \name ->
- findCategory name (_input_paymentCategories input)
-
- category <- _selectOut_value <$> (Component.select $ SelectIn
- { _selectIn_label = Msg.get Msg.Payment_Category
- , _selectIn_initialValue = _input_category input
- , _selectIn_value = setCategory
- , _selectIn_values = R.constDyn categories
- , _selectIn_reset = _input_category input <$ reset
- , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input)
- , _selectIn_validate = confirm
- })
-
- let payment = do
- n <- _inputOut_value name
- c <- cost
- d <- date
- cat <- category
- return ((_input_mkPayload input)
- <$> ValidationUtil.nelError n
- <*> V.Success c
- <*> V.Success d
- <*> ValidationUtil.nelError cat
- <*> V.Success (_input_frequency input))
-
- (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 "/api/payment")
- (ValidationUtil.fireValidation payment confirm)
-
- return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
-
- return Output
- { _output_hide = R.leftmost [ cancel, () <$ addPayment ]
- , _output_addPayment = addPayment
- }
+ rec
+ let reset = R.leftmost
+ [ "" <$ _modalFormOut_cancel modalForm
+ , "" <$ _modalFormOut_validate modalForm
+ , "" <$ _input_cancel input
+ ]
+
+ modalForm <- Component.modalForm $ ModalFormIn
+ { _modalFormIn_headerLabel = _input_headerLabel input
+ , _modalFormIn_ajax = _input_ajax input "/api/payment"
+ , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm)
+ }
+
+ return $ Output
+ { _output_hide = _modalFormOut_hide modalForm
+ , _output_addPayment = _modalFormOut_validate modalForm
+ }
where
+ form
+ :: Event t String
+ -> Event t ()
+ -> m (Dynamic t (Validation (NonEmpty Text) a))
+ form reset confirm = do
+ name <- Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Payment_Name
+ , _inputIn_initialValue = _input_name input
+ , _inputIn_validation = PaymentValidation.name
+ })
+ (_input_name input <$ reset)
+ confirm
+
+ cost <- _inputOut_raw <$> (Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Payment_Cost
+ , _inputIn_initialValue = _input_cost input
+ , _inputIn_validation = PaymentValidation.cost
+ })
+ (_input_cost input <$ reset)
+ confirm)
+
+ let initialDate = T.pack . Calendar.showGregorian . _input_date $ input
+
+ date <- _inputOut_raw <$> (Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Payment_Date
+ , _inputIn_initialValue = initialDate
+ , _inputIn_inputType = "date"
+ , _inputIn_hasResetButton = False
+ , _inputIn_validation = PaymentValidation.date
+ })
+ (initialDate <$ reset)
+ confirm)
+
+ let setCategory =
+ R.fmapMaybe id . R.updated $
+ R.ffor (_inputOut_raw name) $ \name ->
+ findCategory name (_input_paymentCategories input)
+
+ category <- _selectOut_value <$> (Component.select $ SelectIn
+ { _selectIn_label = Msg.get Msg.Payment_Category
+ , _selectIn_initialValue = _input_category input
+ , _selectIn_value = setCategory
+ , _selectIn_values = R.constDyn categories
+ , _selectIn_reset = _input_category input <$ reset
+ , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input)
+ , _selectIn_validate = confirm
+ })
+
+ return $ do
+ n <- _inputOut_value name
+ c <- cost
+ d <- date
+ cat <- category
+ return ((_input_mkPayload input)
+ <$> ValidationUtil.nelError n
+ <*> V.Success c
+ <*> V.Success d
+ <*> ValidationUtil.nelError cat
+ <*> V.Success (_input_frequency input))
+
frequencies =
M.fromList
[ (Punctual, Msg.get Msg.Payment_PunctualMale)
@@ -163,11 +143,6 @@ view input = do
categories = M.fromList . flip map (_input_categories input) $ \c ->
(_category_id c, _category_name c)
- ajax =
- case _input_httpMethod input of
- Post -> Ajax.post
- Put -> Ajax.put
-
findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
findCategory paymentName =
fmap _paymentCategory_category
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 00:22:40 +0000