aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.stylish-haskell.yaml1
-rw-r--r--README.md5
-rw-r--r--client/client.cabal1
-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
-rw-r--r--common/common.cabal1
-rw-r--r--server/server.cabal1
-rw-r--r--server/src/Design/Form.hs33
-rw-r--r--server/src/Design/Global.hs7
-rw-r--r--server/src/Design/Modal.hs39
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")
+ ]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 19:57:38 +0000