3 files changed, 64 insertions, 32 deletions

diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index c1eb4e8..57018a6 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -16,18 +16,16 @@ import           Component.Button (ButtonIn (..), ButtonOut (..))
 import qualified Component.Button as Button
 import qualified Icon
 
-data InputIn t a b = InputIn
-  { _inputIn_reset          :: Event t a
-  , _inputIn_hasResetButton :: Bool
+data InputIn = InputIn
+  { _inputIn_hasResetButton :: Bool
   , _inputIn_label          :: Text
   , _inputIn_initialValue   :: Text
   , _inputIn_inputType      :: Text
   }
 
-defaultInputIn :: (Reflex t) => InputIn t a b
+defaultInputIn :: InputIn
 defaultInputIn = InputIn
-  { _inputIn_reset          = R.never
-  , _inputIn_hasResetButton = True
+  { _inputIn_hasResetButton = True
   , _inputIn_label          = ""
   , _inputIn_initialValue   = ""
   , _inputIn_inputType      = "text"
@@ -38,12 +36,16 @@ data InputOut t = InputOut
   , _inputOut_enter :: Event t ()
   }
 
-input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t)
-input inputIn =
+input
+  :: forall t m a b. MonadWidget t m
+  => InputIn
+  -> Event t a -- reset
+  -> m (InputOut t)
+input inputIn reset =
   R.divClass "textInput" $ do
     rec
       let resetValue = R.leftmost
-            [ fmap (const "") (_inputIn_reset inputIn)
+            [ fmap (const "") reset
             , fmap (const "") resetClic
             ]
 
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index 72091c9..b86fee0 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -4,16 +4,18 @@ module Component.Modal
   , modal
   ) where
 
-import           Control.Monad    (void)
-import qualified Data.Map         as M
-import qualified Data.Map.Lazy    as LM
-import           Data.Text        (Text)
-import qualified GHCJS.DOM.Node   as Node
-import           Reflex.Dom       (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom       as R
-import qualified Reflex.Dom.Class as R
+import           Control.Monad     (void)
+import qualified Data.Map          as M
+import qualified Data.Map.Lazy     as LM
+import           Data.Text         (Text)
+import qualified GHCJS.DOM.Element as Element
+import qualified GHCJS.DOM.Node    as Node
+import           JSDOM.Types       (JSString)
+import           Reflex.Dom        (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom        as R
+import qualified Reflex.Dom.Class  as R
 
-import qualified Util.Dom         as Dom
+import qualified Util.Dom          as Dom
 
 data ModalIn t m a = ModalIn
   { _modalIn_show    :: Event t ()
@@ -28,20 +30,21 @@ data ModalOut a = ModalOut
 modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a)
 modal modalIn = do
   rec
-    showModal <- R.holdDyn False $ R.leftmost
-      [ True <$ _modalIn_show modalIn
-      , False <$ _modalIn_hide modalIn
-      , False <$ curtainClick
-      ]
+    let showEvent = R.leftmost
+          [ True <$ _modalIn_show modalIn
+          , False <$ _modalIn_hide modalIn
+          , False <$ curtainClick
+          ]
 
-    (elem, (curtainClick, content)) <- R.buildElement "div" (getAttributes <$> showModal) $ do
-      (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank
-      cont <- R.divClass "modalContent" $ _modalIn_content modalIn
-      return (R.domEvent R.Click curtain, cont)
+    showModal <- R.holdDyn False showEvent
 
-  body <- Dom.getBody
-  let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn)
-  R.performEvent_ $ void `fmap` moveBackdrop
+    (elem, (curtainClick, content)) <-
+      R.buildElement "div" (getAttributes <$> showModal) $ do
+        (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank
+        cont <- R.divClass "modalContent" $ _modalIn_content modalIn
+        return (R.domEvent R.Click curtain, cont)
+
+  performShowEffects showEvent elem
 
   return $ ModalOut
     { _modalOut_content = content
@@ -53,3 +56,24 @@ getAttributes show =
     [ ("style", if show then "display:block" else "display:none")
     , ("class", "modal")
     ]
+
+performShowEffects
+  :: forall t m a. MonadWidget t m
+  => Event t Bool
+  -> Element.Element
+  -> m ()
+performShowEffects showEvent elem = do
+  body <- Dom.getBody
+
+  let showEffects =
+        flip fmap showEvent (\show -> do
+          if show
+            then
+              do
+                Node.appendChild body elem
+                Element.setClassName body ("modal" :: JSString)
+            else
+              Element.setClassName body ("" :: JSString)
+        )
+
+  R.performEvent_ $ void `fmap` showEffects
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 17a4958..7cb6726 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -6,13 +6,14 @@ module Component.Select
 
 import           Data.Map   (Map)
 import           Data.Text  (Text)
-import           Reflex.Dom (Dynamic, MonadWidget, Reflex)
+import           Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom as R
 
 data (Reflex t) => SelectIn t a = SelectIn
   { _selectIn_label        :: Text
   , _selectIn_initialValue :: a
   , _selectIn_values       :: Dynamic t (Map a Text)
+  , _selectIn_reset        :: Event t ()
   }
 
 data SelectOut t a = SelectOut
@@ -24,8 +25,13 @@ select selectIn =
   R.divClass "selectInput" $ do
     R.el "label" $ R.text (_selectIn_label selectIn)
 
+    let initialValue = _selectIn_initialValue selectIn
+
     value <- R._dropdown_value <$>
-      R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def
+      R.dropdown
+        initialValue
+        (_selectIn_values selectIn)
+        (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) })
 
     return SelectOut
       { _selectOut_value = value