Create ModalForm component

6 files changed, 155 insertions, 200 deletions

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