diff options
| -rw-r--r-- | client/client.cabal | 1 | ||||
| -rw-r--r-- | client/src/Component.hs | 15 | ||||
| -rw-r--r-- | client/src/Component/ModalForm.hs | 70 | ||||
| -rw-r--r-- | client/src/View/Income/Add.hs | 3 | ||||
| -rw-r--r-- | client/src/View/Income/Form.hs | 138 | ||||
| -rw-r--r-- | client/src/View/Payment/Add.hs | 3 | ||||
| -rw-r--r-- | client/src/View/Payment/Clone.hs | 3 | ||||
| -rw-r--r-- | client/src/View/Payment/Edit.hs | 3 | ||||
| -rw-r--r-- | client/src/View/Payment/Form.hs | 205 | ||||
| -rw-r--r-- | common/common.cabal | 1 | ||||
| -rw-r--r-- | server/server.cabal | 1 |
11 files changed, 236 insertions, 207 deletions
diff --git a/client/client.cabal b/client/client.cabal index 9e0a47e..a7d3751 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -20,6 +20,7 @@ Executable client MultiParamTypeClasses OverloadedStrings RecursiveDo + ScopedTypeVariables Build-depends: aeson 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 diff --git a/common/common.cabal b/common/common.cabal index 6c7c779..1a441c5 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -19,6 +19,7 @@ Library LambdaCase MultiParamTypeClasses OverloadedStrings + ScopedTypeVariables Build-depends: aeson diff --git a/server/server.cabal b/server/server.cabal index eeba14f..f1105ff 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -19,6 +19,7 @@ Executable server LambdaCase MultiParamTypeClasses OverloadedStrings + ScopedTypeVariables Build-depends: aeson |