From c542424b7b41c78a170763f6996c12f56b359860 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 21:31:27 +0200 Subject: Add smooth transitions to modal show and hide --- client/client.cabal | 1 + client/src/Component/Modal.hs | 79 ++++++++++++++++++++++++++------------- client/src/Component/Select.hs | 4 +- client/src/Util/WaitFor.hs | 2 +- client/src/View/Payment.hs | 4 +- client/src/View/Payment/Add.hs | 8 ++-- client/src/View/Payment/Header.hs | 2 +- client/src/View/SignIn.hs | 4 +- 8 files changed, 65 insertions(+), 39 deletions(-) (limited to 'client') 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 -- cgit v1.2.3