Add smooth transitions to modal show and hide

2 files changed, 54 insertions, 29 deletions

diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index d7943a9..fac417e 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -8,6 +8,8 @@ import           Control.Monad     (void)
 import qualified Data.Map          as M
 import qualified Data.Map.Lazy     as LM
 import           Data.Text         (Text)
+import qualified Data.Text         as T
+import           Data.Time.Clock   (NominalDiffTime)
 import qualified GHCJS.DOM.Element as Element
 import qualified GHCJS.DOM.Node    as Node
 import           JSDOM.Types       (JSString)
@@ -31,52 +33,75 @@ data ModalOut t a = ModalOut
 modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a)
 modal modalIn = do
   rec
-    let showEvent = R.leftmost
-          [ True <$ _modalIn_show modalIn
-          , False <$ _modalIn_hide modalIn
-          , False <$ curtainClick
-          ]
+    let show = Show <$ (_modalIn_show modalIn)
 
-    showModal <- R.holdDyn False showEvent
+        startHiding =
+          R.attachWithMaybe
+            (\a _ -> if a then Just StartHiding else Nothing)
+            (R.current canBeHidden)
+            (R.leftmost [ _modalIn_hide modalIn, curtainClick ])
+
+    canBeHidden <-
+      R.holdDyn True $ R.leftmost
+        [ False <$ startHiding
+        , True <$ endHiding
+        ]
+
+    endHiding <-
+      R.delay (0.2 :: NominalDiffTime) (EndHiding <$ startHiding)
+
+    let action =
+          R.leftmost [ show, startHiding, endHiding ]
+
+    modalClass <-
+      R.holdDyn "" (fmap getModalClass action)
 
     (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)
+      R.buildElement "div" (fmap getAttributes modalClass) $ do
+        (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank
+        content <- R.divClass "g-Modal__Content" $ _modalIn_content modalIn
+        return (R.domEvent R.Click curtain, content)
 
-  performShowEffects showEvent elem
+  performShowEffects action elem
 
   return $ ModalOut
     { _modalOut_content = content
     , _modalOut_hide = curtainClick
     }
 
-getAttributes :: Bool -> LM.Map Text Text
-getAttributes show =
-  M.fromList $
-    [ ("style", if show then "display:block" else "display:none")
-    , ("class", "modal")
-    ]
+getAttributes :: Text -> LM.Map Text Text
+getAttributes modalClass =
+  M.singleton "class" $
+    T.intercalate " " [ "g-Modal", modalClass]
 
 performShowEffects
   :: forall t m a. MonadWidget t m
-  => Event t Bool
+  => Event t Action
   -> 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
-            do
-              Node.removeChild body elem
-              Element.setClassName body ("" :: JSString)
+        flip fmap showEvent (\case
+          Show -> do
+            Node.appendChild body elem
+            Element.setClassName body ("g-Body--Modal" :: JSString)
+          StartHiding ->
+            return ()
+          EndHiding -> do
+            Node.removeChild body elem
+            Element.setClassName body ("" :: JSString)
         )
 
   R.performEvent_ $ void `fmap` showEffects
+
+data Action
+  = Show
+  | StartHiding
+  | EndHiding
+
+getModalClass :: Action -> Text
+getModalClass Show        = "g-Modal--Show"
+getModalClass StartHiding = "g-Modal--Hiding"
+getModalClass _           = ""
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index cf62f26..9a37afc 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -51,7 +51,7 @@ select selectIn = do
           fmap ValidationUtil.maybeError validatedValue
 
     showedError <- R.holdDyn Nothing $ R.leftmost
-      [ const Nothing <$> _selectIn_reset selectIn
+      [ Nothing <$ _selectIn_reset selectIn
       , R.updated maybeError
       , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn)
       ]
@@ -62,7 +62,7 @@ select selectIn = do
       let initialValue = _selectIn_initialValue selectIn
 
       let setValue = R.leftmost
-            [ const initialValue <$> (_selectIn_reset selectIn)
+            [ initialValue <$ (_selectIn_reset selectIn)
             , _selectIn_value selectIn
             ]