1 files changed, 70 insertions, 0 deletions
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
+        }