Add smooth transitions to modal show and hide

15 files changed, 108 insertions, 83 deletions

diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml
index a3f992d..034ace0 100644
--- a/.stylish-haskell.yaml
+++ b/.stylish-haskell.yaml
@@ -27,6 +27,7 @@ newline: native
 
 language_extensions:
   - ExistentialQuantification
+  - LambdaCase
   - MultiParamTypeClasses
   - OverloadedStrings
   - RecursiveDo
diff --git a/README.md b/README.md
index dfa417f..19309f5 100644
--- a/README.md
+++ b/README.md
@@ -60,9 +60,10 @@ See [application.conf](application.conf).
 
 ### Payment view
 
-- Edit a payment.
+- Edit a payment
 - Possibly remove payment category after payment edit
-- Clone a payment.
+- Clone a payment
+- Add icon tooltip
 
 ### Income view
 
diff --git a/client/client.cabal b/client/client.cabal
index af71f2d..ce3c059 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -16,6 +16,7 @@ Executable client
 
   Default-extensions:
     ExistentialQuantification
+    LambdaCase
     MultiParamTypeClasses
     OverloadedStrings
     RecursiveDo
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
             ]
 
diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
index 02edff5..fe7b733 100644
--- a/client/src/Util/WaitFor.hs
+++ b/client/src/Util/WaitFor.hs
@@ -13,5 +13,5 @@ waitFor
   -> m (Event t b, Event t Bool)
 waitFor op input = do
   result <- op input >>= R.debounce (0.5 :: NominalDiffTime)
-  let waiting = R.leftmost [ const True <$> input , const False <$> result ]
+  let waiting = R.leftmost [ True <$ input , False <$ result ]
   return (result, waiting)
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 46ab642..f363b06 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -73,8 +73,8 @@ widget paymentIn = do
         { _pagesIn_total = length <$> searchPayments
         , _pagesIn_perPage = paymentsPerPage
         , _pagesIn_reset = R.leftmost $
-            [ const () <$> searchNameEvent
-            , const () <$> _headerOut_addPayment header
+            [ () <$ searchNameEvent
+            , () <$ _headerOut_addPayment header
             ]
         }
 
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index d2d2dc4..69e29a7 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -55,9 +55,9 @@ view addIn = do
     R.divClass "addContent" $ do
       rec
         let reset = R.leftmost
-              [ const "" <$> cancel
-              , const "" <$> addPayment
-              , const "" <$> _addIn_cancel addIn
+              [ "" <$ cancel
+              , "" <$ addPayment
+              , "" <$ _addIn_cancel addIn
               ]
 
         name <- Component.input
@@ -90,7 +90,7 @@ view addIn = do
             , _inputIn_hasResetButton = False
             , _inputIn_validation = PaymentValidation.date
             })
-          (const currentDay <$> reset)
+          (currentDay <$ reset)
           confirm)
 
         let setCategory =
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index fa21731..1bdee8d 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -144,7 +144,7 @@ searchLine reset = do
   R.divClass "searchLine" $ do
     searchName <- _inputOut_raw <$> (Component.input
       ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name })
-      (const "" <$> reset)
+      ("" <$ reset)
       R.never)
 
     let frequencies = M.fromList
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 6fbf6d6..f8b985f 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -37,7 +37,7 @@ view signInMessage =
             { _inputIn_label = Msg.get Msg.SignIn_EmailLabel
             , _inputIn_validation = SignInValidation.email
             })
-          (const "" <$> R.ffilter Either.isRight signInResult)
+          ("" <$ R.ffilter Either.isRight signInResult)
           validate)
 
         validate <- _buttonOut_clic <$> (Component.button $
@@ -52,7 +52,7 @@ view signInMessage =
         (signInResult, waiting) <- WaitFor.waitFor
           (Ajax.postJson "/askSignIn")
           (ValidationUtil.fireMaybe
-            ((\f -> const f <$> SignInValidation.signIn f) <$> form)
+            ((\f -> f <$ SignInValidation.signIn f) <$> form)
             validate)
 
       showSignInResult signInMessage signInResult
diff --git a/common/common.cabal b/common/common.cabal
index b7e0416..0edd8e2 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -16,6 +16,7 @@ Library
   Default-extensions:
     DeriveGeneric
     ExistentialQuantification
+    LambdaCase
     MultiParamTypeClasses
     OverloadedStrings
 
diff --git a/server/server.cabal b/server/server.cabal
index d6c4a9b..3bc8e42 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -16,6 +16,7 @@ Executable server
 
   Default-extensions:
     ExistentialQuantification
+    LambdaCase
     MultiParamTypeClasses
     OverloadedStrings
 
diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs
index 31a2127..0f236f7 100644
--- a/server/src/Design/Form.hs
+++ b/server/src/Design/Form.hs
@@ -14,7 +14,6 @@ design = do
   let inputHeight = 30
   let inputTop = 22
   let inputPaddingBottom = 3
-  let inputZIndex = 1
 
   label ? do
     cursor pointer
@@ -29,9 +28,9 @@ design = do
     input ? do
       width (pct 100)
       position relative
-      zIndex inputZIndex
       backgroundColor transparent
       paddingBottom (px inputPaddingBottom)
+      paddingRight (px 14) -- Space for the delete icon
       borderStyle none
       borderBottom solid (px 1) Color.dustyGray
       marginBottom (px 5)
@@ -52,7 +51,6 @@ design = do
       position absolute
       right (px 0)
       top (px 27)
-      zIndex inputZIndex
       svg ? "path" ?
         ("fill" -: Color.toString Color.silver)
       hover & svg ? "path" ?
@@ -80,35 +78,6 @@ design = do
       borderColor transparent
       backgroundColor transparent
 
-  ".radioGroup" ? do
-    position relative
-    marginBottom (em 2)
-
-    ".title" ? do
-      color Color.silver
-      marginBottom (em 0.8)
-
-    ".radioInputs" ? do
-      display flex
-      "justify-content" -: "center"
-
-      ".radioInput:not(:last-child)::after" ? do
-        content (stringContent "/")
-        marginLeft (px 10)
-        marginRight (px 10)
-
-      input ? do
-        opacity 0
-        width (px 30)
-        margin (px 0) (px (-15)) (px 0) (px (-15))
-
-      "input:focus + label" ? do
-        textDecoration underline
-
-      "input:checked + label" ? do
-        color Color.chestnutRose
-        fontWeight bold
-
   ".selectInput" ? do
     marginBottom (em 2)
 
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index 66e9f47..24d999f 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -22,7 +22,7 @@ globalDesign = renderWith compact [] global
 global :: Css
 global = do
   ".errors" ? Errors.design
-  ".modal" ? Modal.design
+  Modal.design
   ".tooltip" ? Tooltip.design
   Views.design
   Form.design
@@ -33,13 +33,14 @@ global = do
   html ? do
     height (pct 100)
 
+  "g-Body--Modal" ?
+    overflowY hidden
+
   body ? do
     position relative
     minWidth (px 320)
     height (pct 100)
     fontFamily ["Cantarell"] [sansSerif]
-    ".modal" &
-      overflowY hidden
     Media.tablet $ do
       fontSize (px 15)
       button ? fontSize (px 15)
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index 9c016b9..dce2ef9 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -11,24 +11,37 @@ import qualified Design.View.Payment.Delete as Delete
 design :: Css
 design = do
 
-  ".modalCurtain" ? do
+  appearKeyframe
+
+  ".g-Modal" ? do
+    appearAnimation
+    transition "all" (sec 0.2) ease (sec 0)
+    display none
+    opacity 0
+
+  ".g-Modal--Show" & do
+    display block
+    opacity 1
+
+  ".g-Modal--Hiding" & do
+    display block
+
+  ".g-Modal__Curtain" ? do
     position fixed
     top (px 0)
     left (px 0)
     width (pct 100)
     height (pct 100)
-    backgroundColor (rgba 0 0 0 0.7)
-    zIndex 1000
-    opacity 1
-    transition "all" (sec 0.2) ease (sec 0)
+    backgroundColor (rgba 0 0 0 0.6)
+    zIndex 1
 
-  ".modalContent" ? do
+  ".g-Modal__Content" ? do
     minWidth (px 300)
     position fixed
     top (pct 25)
     left (pct 50)
     "transform" -: "translate(-50%, -25%)"
-    zIndex 1000
+    zIndex 1
     backgroundColor white
     sym borderRadius (px 5)
     boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15)
@@ -44,3 +57,15 @@ design = do
 
   ".deletePaymentModal" <> ".deleteIncomeModal" ? do
     h1 ? marginBottom (em 1.5)
+
+appearAnimation :: Css
+appearAnimation = do
+  animationName "appear"
+  animationDuration (sec 0.15)
+  animationTimingFunction easeIn
+
+appearKeyframe :: Css
+appearKeyframe = keyframes
+  "appear"
+  [ (0, "opacity" -: "0")
+  ]