1 files changed, 80 insertions, 0 deletions
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
new file mode 100644
index 0000000..70f5f58
--- /dev/null
+++ b/client/src/Component/Select.hs
@@ -0,0 +1,80 @@
+module Component.Select
+  ( view
+  , In(..)
+  , Out(..)
+  ) where
+
+import           Data.Map        (Map)
+import qualified Data.Map        as M
+import qualified Data.Maybe      as Maybe
+import           Data.Text       (Text)
+import qualified Data.Text       as T
+import           Data.Validation (Validation)
+import           Reflex.Dom      (Dynamic, Event, MonadWidget, Reflex)
+import qualified Reflex.Dom      as R
+
+import qualified Util.Validation as ValidationUtil
+
+data (Reflex t) => In t a b c = In
+  { _in_label        :: Text
+  , _in_initialValue :: a
+  , _in_value        :: Event t a
+  , _in_values       :: Dynamic t (Map a Text)
+  , _in_reset        :: Event t b
+  , _in_isValid      :: a -> Validation Text a
+  , _in_validate     :: Event t c
+  }
+
+data Out t a = Out
+  { _out_raw   :: Dynamic t a
+  , _out_value :: Dynamic t (Validation Text a)
+  }
+
+view :: forall t m a b c. (Ord a, MonadWidget t m) => In t a b c -> m (Out t a)
+view input = do
+  rec
+    let containerAttr = R.ffor showedError (\e ->
+          M.singleton "class" $ T.intercalate " "
+            [ "input selectInput"
+            , if Maybe.isJust e then "error" else ""
+            ])
+
+        validatedValue =
+          fmap (_in_isValid input) value
+
+        maybeError =
+          fmap ValidationUtil.maybeError validatedValue
+
+    showedError <- R.holdDyn Nothing $ R.leftmost
+      [ Nothing <$ _in_reset input
+      , R.updated maybeError
+      , R.attachWith const (R.current maybeError) (_in_validate input)
+      ]
+
+    value <- R.elDynAttr "div" containerAttr $ do
+      let initialValue = _in_initialValue input
+
+      let setValue = R.leftmost
+            [ initialValue <$ (_in_reset input)
+            , _in_value input
+            ]
+
+      value <- R.el "label" $ do
+        R.divClass "label" $
+          R.text (_in_label input)
+
+        R._dropdown_value <$>
+          R.dropdown
+            initialValue
+            (_in_values input)
+            (R.def { R._dropdownConfig_setValue = setValue })
+
+      R.divClass "errorMessage" . R.dynText $
+        R.ffor showedError (Maybe.fromMaybe "")
+
+      return value
+
+  return Out
+    { _out_raw = value
+    , _out_value = validatedValue
+    }