aboutsummaryrefslogtreecommitdiff
path: root/client/src
diff options
context:
space:
mode:
Diffstat (limited to 'client/src')
-rw-r--r--client/src/Component/Modal.hs79
-rw-r--r--client/src/Component/Select.hs4
-rw-r--r--client/src/Util/WaitFor.hs2
-rw-r--r--client/src/View/Payment.hs4
-rw-r--r--client/src/View/Payment/Add.hs8
-rw-r--r--client/src/View/Payment/Header.hs2
-rw-r--r--client/src/View/SignIn.hs4
7 files changed, 64 insertions, 39 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
]
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 00:11:11 +0000