From ab17b6339d16970c3845ec4f153bfeed89eae728 Mon Sep 17 00:00:00 2001 From: Joris Date: Fri, 5 Jan 2018 14:45:47 +0100 Subject: Add modal component --- 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 +++++++++++++++++++++++--------------- 6 files changed, 127 insertions(+), 65 deletions(-) create mode 100644 client/src/Component/Modal.hs (limited to 'client') 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) -- cgit v1.2.3