From ab17b6339d16970c3845ec4f153bfeed89eae728 Mon Sep 17 00:00:00 2001 From: Joris Date: Fri, 5 Jan 2018 14:45:47 +0100 Subject: Add modal component --- README.md | 5 +- client/client.cabal | 1 + client/src/Component.hs | 1 + client/src/Component/Button.hs | 4 +- client/src/Component/Modal.hs | 38 ++++++++++ client/src/View/Payment.hs | 18 ++--- client/src/View/Payment/Header.hs | 130 +++++++++++++++++++++-------------- common/src/Common/Model/Frequency.hs | 2 +- public/css/reset.css | 12 ---- server/server.cabal | 2 +- server/src/Design/Dialog.hs | 22 ------ server/src/Design/Global.hs | 16 ++--- server/src/Design/Modal.hs | 43 ++++++++++++ 13 files changed, 184 insertions(+), 110 deletions(-) create mode 100644 client/src/Component/Modal.hs delete mode 100644 server/src/Design/Dialog.hs create mode 100644 server/src/Design/Modal.hs diff --git a/README.md b/README.md index 34ae53e..ec8c139 100644 --- a/README.md +++ b/README.md @@ -60,8 +60,10 @@ TODO ### Interface -- Search payments by frequency. - Add a payment. +- Edit a payment. +- Delete a payment. +- Clone a payment. #### Bonus @@ -76,6 +78,7 @@ TODO - R.def for custom components. - Move up element ids security (editOwn is actually at db level). - move persistence methods to a module. +- try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) ### Tooling diff --git a/client/client.cabal b/client/client.cabal index 02a7549..1064e7d 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -34,6 +34,7 @@ Executable client other-modules: Component.Button Component.Input + Component.Modal Icon Util.List View.App diff --git a/client/src/Component.hs b/client/src/Component.hs index 4c9541b..dea384e 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -2,3 +2,4 @@ module Component (module X) where import Component.Button as X import Component.Input as X +import Component.Modal as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 754b903..3ee9561 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,8 +1,8 @@ module Component.Button ( ButtonIn(..) - , buttonInDefault , ButtonOut(..) , button + , buttonInDefault ) where import qualified Data.Map as M @@ -19,7 +19,7 @@ data ButtonIn t m = ButtonIn , _buttonIn_waiting :: Event t Bool } -buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m +buttonInDefault :: forall t m. (MonadWidget t m) => ButtonIn t m buttonInDefault = ButtonIn { _buttonIn_class = R.constDyn "" , _buttonIn_content = R.blank diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs new file mode 100644 index 0000000..bfb5e02 --- /dev/null +++ b/client/src/Component/Modal.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Component.Modal + ( ModalIn(..) + , ModalOut(..) + , modal + ) where + +import qualified Data.Map as M +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +data ModalIn t m = ModalIn + { _modalIn_show :: Event t () + , _modalIn_content :: m () + } + +data ModalOut = ModalOut {} + +modal :: forall t m. MonadWidget t m => ModalIn t m -> m ModalOut +modal modalIn = do + rec + showModal <- R.holdDyn False $ R.leftmost + [ True <$ _modalIn_show modalIn + , False <$ curtainClick + ] + + let attr = flip fmap showModal (\s -> M.fromList $ + [ ("style", if s then "display:block" else "display:none") + , ("class", "modal") + ]) + + curtainClick <- R.elDynAttr "div" attr $ do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "curtain") $ R.blank + R.divClass "content" $ _modalIn_content modalIn + return $ R.domEvent R.Click curtain + + return $ ModalOut {} diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f4aaf5c..42da8fb 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -8,8 +8,7 @@ import Prelude hiding (init) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Frequency (..), Init (..), Payment (..)) -import Common.Util.Text as T +import Common.Model (Init (..)) import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header @@ -31,13 +30,6 @@ widget paymentIn = do R.divClass "payment" $ do rec let init = _paymentIn_init paymentIn - - filterPayment s p = search s (_payment_name p) && (_payment_frequency p == Punctual) - - payments = fmap - (\s -> filter (filterPayment s) (_init_payments init)) - (_headerOut_search header) - paymentsPerPage = 7 header <- Header.widget $ HeaderIn @@ -47,14 +39,14 @@ widget paymentIn = do _ <- Table.widget $ TableIn { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = payments + , _tableIn_payments = _headerOut_searchPayments header , _tableIn_perPage = paymentsPerPage } pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> payments + { _pagesIn_total = length <$> _headerOut_searchPayments header , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_search header + , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_searchName header } - return $ PaymentOut {} + pure $ PaymentOut {} diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index f64f11d..a694136 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -7,23 +7,26 @@ module View.Payment.Header import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) import qualified Data.List as L hiding (groupBy) +import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget, Reflex) import qualified Reflex.Dom as R import Common.Model (Currency, ExceedingPayer (..), Frequency (..), Income (..), Init (..), - Payment (..), User (..), UserId) + Payment (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg +import qualified Common.Util.Text as T import qualified Common.View.Format as Format -import Component (ButtonIn (..), InputIn (..), - InputOut (..)) +import Component (ButtonIn (..), ButtonOut (..), + InputIn (..), InputOut (..), + ModalIn (..)) import qualified Component as Component import qualified Util.List as L @@ -32,23 +35,37 @@ data HeaderIn t = HeaderIn } data HeaderOut t = HeaderOut - { _headerOut_search :: Dynamic t Text + { _headerOut_searchName :: Dynamic t Text + , _headerOut_searchPayments :: Dynamic t [Payment] } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - payerAndAdd incomes payments users currency - search <- searchLine - infos payments users currency + payerAndAdd incomes punctualPayments users currency + (searchName, searchFrequency) <- searchLine + let searchPayments = getSearchPayments searchName searchFrequency payments + infos searchPayments users currency return $ HeaderOut - { _headerOut_search = search + { _headerOut_searchName = searchName + , _headerOut_searchPayments = searchPayments } - where init = _headerIn_init headerIn - incomes = _init_incomes init - payments = filter ((==) Punctual . _payment_frequency) (_init_payments init) - users = _init_users init - currency = _init_currency init + where + init = _headerIn_init headerIn + incomes = _init_incomes init + payments = _init_payments init + punctualPayments = filter ((==) Punctual . _payment_frequency) payments + users = _init_users init + currency = _init_currency init + +getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment] +getSearchPayments name frequency payments = do + n <- name + f <- frequency + pure $ flip filter payments (\p -> + ( T.search n (_payment_name p) + && (_payment_frequency p == f) + )) payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m () payerAndAdd incomes payments users currency = do @@ -65,49 +82,62 @@ payerAndAdd incomes payments users currency = do R.text "+ " R.text . Format.price currency $ _exceedingPayer_amount p ) - _ <- Component.button $ ButtonIn + addPayment <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add , _buttonIn_waiting = R.never + }) + _ <- Component.modal $ ModalIn + { _modalIn_show = addPayment + , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement" } return () -infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m () +searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) +searchLine = do + R.divClass "searchLine" $ do + searchName <- _inputOut_value <$> (Component.input $ InputIn + { _inputIn_reset = R.never + , _inputIn_label = Msg.get Msg.Search_Name + }) + + let frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + searchFrequency <- R._dropdown_value <$> + R.dropdown Punctual (R.constDyn frequencies) R.def + + return (searchName, searchFrequency) + +infos :: forall t m. MonadWidget t m => Dynamic t [Payment] -> [User] -> Currency -> m () infos payments users currency = R.divClass "infos" $ do - R.elClass "span" "total" $ do - R.text . Msg.get $ Msg.Payment_Worth - (T.intercalate " " - [ (Format.number paymentCount) - , if paymentCount > 1 - then Msg.get Msg.Payment_Many - else Msg.get Msg.Payment_One - ]) - (Format.price currency total) - R.elClass "span" "partition" . R.text $ - T.intercalate ", " - . map (\(userId, userTotal) -> - Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name $ CM.findUser userId users) - (Format.price currency userTotal) - ) - $ totalByUser - where paymentCount = length payments - total = sum . map _payment_cost $ payments - - totalByUser :: [(UserId, Int)] - totalByUser = - L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ payments + R.elClass "span" "total" $ do + R.dynText $ do + ps <- payments + let paymentCount = length ps + total = sum . map _payment_cost $ ps + pure . Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency total) -searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text) -searchLine = - R.divClass "searchLine" $ - _inputOut_value <$> (Component.input $ InputIn - { _inputIn_reset = R.never - , _inputIn_label = Msg.get Msg.Search_Name - }) + R.elClass "span" "partition" . R.dynText $ do + ps <- payments + let totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . map (\(u, xs) -> (u, sum . map snd $ xs)) + . L.groupBy fst + . map (\p -> (_payment_user p, _payment_cost p)) + $ ps + pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) + (Format.price currency userTotal) diff --git a/common/src/Common/Model/Frequency.hs b/common/src/Common/Model/Frequency.hs index ee502e8..48e75ea 100644 --- a/common/src/Common/Model/Frequency.hs +++ b/common/src/Common/Model/Frequency.hs @@ -8,7 +8,7 @@ import GHC.Generics (Generic) data Frequency = Punctual | Monthly - deriving (Eq, Read, Show, Generic) + deriving (Eq, Read, Show, Generic, Ord) instance FromJSON Frequency instance ToJSON Frequency diff --git a/public/css/reset.css b/public/css/reset.css index 42f3b8c..2eecc94 100644 --- a/public/css/reset.css +++ b/public/css/reset.css @@ -56,17 +56,5 @@ button:hover { cursor: pointer; } button::-moz-focus-inner { border: 0; } :focus { outline: none; } -select:-moz-focusring { - color: transparent; - text-shadow: 0 0 0 #000; -} -select { - -webkit-appearance: none; - -moz-appearance: none; - text-indent: 1px; - text-overflow: ''; - cursor: pointer; -} - html { box-sizing: border-box; } *, *:before, *:after { box-sizing: inherit; } diff --git a/server/server.cabal b/server/server.cabal index d1dbd50..ada7040 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -63,12 +63,12 @@ Executable server Cookie Design.Color Design.Constants - Design.Dialog Design.Errors Design.Form Design.Global Design.Helper Design.Media + Design.Modal Design.Tooltip Design.View.Header Design.View.Payment diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs deleted file mode 100644 index 034a8b1..0000000 --- a/server/src/Design/Dialog.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Design.Dialog - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -design :: Css -design = do - - ".content" ? do - minWidth (px 270) - - ".paymentDialog" & do - ".radioGroup" ? ".title" ? display none - ".selectInput" ? do - select ? width (pct 100) - marginBottom (em 1) - - ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do - h1 ? marginBottom (em 1.5) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 5e5035c..4da4ffb 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -3,19 +3,17 @@ module Design.Global ) where import Clay - import Data.Text.Lazy (Text) -import qualified Design.Dialog as Dialog -import qualified Design.Errors as Errors -import qualified Design.Form as Form -import qualified Design.Tooltip as Tooltip -import qualified Design.Views as Views - import qualified Design.Color as Color import qualified Design.Constants as Constants +import qualified Design.Errors as Errors +import qualified Design.Form as Form import qualified Design.Helper as Helper import qualified Design.Media as Media +import qualified Design.Modal as Modal +import qualified Design.Tooltip as Tooltip +import qualified Design.Views as Views globalDesign :: Text globalDesign = renderWith compact [] global @@ -23,7 +21,7 @@ globalDesign = renderWith compact [] global global :: Css global = do ".errors" ? Errors.design - ".dialog" ? Dialog.design + ".modal" ? Modal.design ".tooltip" ? Tooltip.design Views.design Form.design @@ -84,6 +82,8 @@ global = do rotateKeyframes rotateAnimation + select ? cursor pointer + rotateAnimation :: Css rotateAnimation = do animationName "rotate" diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs new file mode 100644 index 0000000..2612257 --- /dev/null +++ b/server/src/Design/Modal.hs @@ -0,0 +1,43 @@ +module Design.Modal + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +design :: Css +design = do + + ".curtain" ? do + position fixed + cursor pointer + top (px 0) + left (px 0) + width (pct 100) + height (pct 100) + backgroundColor (rgba 0 0 0 0.5) + zIndex 1000 + opacity 1 + transition "all" (sec 0.2) ease (sec 0) + + ".content" ? do + minWidth (px 270) + position fixed + top (pct 25) + left (pct 50) + "transform" -: "translate(-50%, -25%)" + zIndex 1000 + backgroundColor white + sym padding (px 20) + sym borderRadius (px 5) + boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5) + + ".paymentModal" & do + ".radioGroup" ? ".title" ? display none + ".selectInput" ? do + select ? width (pct 100) + marginBottom (em 1) + + ".deletePaymentModal" <> ".deleteIncomeModal" ? do + h1 ? marginBottom (em 1.5) -- cgit v1.2.3