From 04c59f08f100ba6a0658d1f2b357f7d8b1e14218 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 13 Oct 2019 22:38:35 +0200 Subject: Show income table --- client/client.cabal | 4 +- client/src/Component.hs | 1 + client/src/Component/Table.hs | 38 +++++++++ client/src/View/App.hs | 40 +++++----- client/src/View/Income/Income.hs | 68 ++++++++++++++++ client/src/View/Payment.hs | 154 ------------------------------------- client/src/View/Payment/Payment.hs | 154 +++++++++++++++++++++++++++++++++++++ client/src/View/Payment/Table.hs | 3 - 8 files changed, 286 insertions(+), 176 deletions(-) create mode 100644 client/src/Component/Table.hs create mode 100644 client/src/View/Income/Income.hs delete mode 100644 client/src/View/Payment.hs create mode 100644 client/src/View/Payment/Payment.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 55ba5e1..f8fe1e1 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -50,6 +50,7 @@ Executable client Component.Input Component.Link Component.Modal + Component.Table Component.Select Icon Util.Ajax @@ -62,8 +63,8 @@ Executable client Util.WaitFor View.App View.Header + View.Income.Income View.NotFound - View.Payment View.Payment.Add View.Payment.Clone View.Payment.Delete @@ -71,5 +72,6 @@ Executable client View.Payment.Form View.Payment.Header View.Payment.Pages + View.Payment.Payment View.Payment.Table View.SignIn diff --git a/client/src/Component.hs b/client/src/Component.hs index 7e0b151..97c250e 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -6,3 +6,4 @@ import Component.Input as X import Component.Link as X import Component.Modal as X import Component.Select as X +import Component.Table as X diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs new file mode 100644 index 0000000..a77a18d --- /dev/null +++ b/client/src/Component/Table.hs @@ -0,0 +1,38 @@ +module Component.Table + ( table + , TableIn(..) + , TableOut(..) + ) where + +import Data.Text (Text) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +data TableIn h r t = TableIn + { _tableIn_headerLabel :: h -> Text + , _tableIn_rows :: Dynamic t [r] + , _tableIn_cell :: h -> r -> Text + } + +data TableOut = TableOut + {} + +table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => TableIn h r t -> m (TableOut) +table tableIn = do + R.divClass "table" $ do + + R.divClass "lines" $ do + R.divClass "header" $ do + flip mapM_ [minBound..] $ \header -> + R.divClass "cell" . R.text $ + _tableIn_headerLabel tableIn header + + R.simpleList (_tableIn_rows tableIn) $ \r -> + R.divClass "row" $ + flip mapM_ [minBound..] $ \h -> + R.divClass "cell name" $ + R.dynText $ + R.ffor r (_tableIn_cell tableIn h) + + return $ TableOut + {} diff --git a/client/src/View/App.hs b/client/src/View/App.hs index d853c7e..3292336 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,22 +2,24 @@ module View.App ( widget ) where -import qualified Data.Text as T -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init, InitResult (..)) -import qualified Common.Msg as Msg - -import Model.Route (Route (..)) -import qualified Util.Router as Router -import View.Header (HeaderIn (..)) -import qualified View.Header as Header -import qualified View.NotFound as NotFound -import View.Payment (PaymentIn (..)) -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init, InitResult (..)) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Router as Router +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import View.Income.Income (IncomeIn (..)) +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import View.Payment.Payment (PaymentIn (..)) +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = @@ -59,12 +61,14 @@ signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case RootRoute -> - Payment.widget $ PaymentIn + Payment.view $ PaymentIn { _paymentIn_init = init } IncomeRoute -> - R.el "div" $ R.text "Incomes" + Income.view $ IncomeIn + { _incomeIn_init = init + } NotFoundRoute -> NotFound.view diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs new file mode 100644 index 0000000..5e9ce1d --- /dev/null +++ b/client/src/View/Income/Income.hs @@ -0,0 +1,68 @@ +module View.Income.Income + ( view + , IncomeIn(..) + ) where + +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income (..), Init (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format +import Component (TableIn (..)) +import qualified Component + +data IncomeIn = IncomeIn + { _incomeIn_init :: Init + } + +view :: forall t m. MonadWidget t m => IncomeIn -> m () +view incomeIn = + R.elClass "main" "income" $ do + + R.divClass "withMargin" $ + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ + Msg.get Msg.Income_MonthlyNet + + Component.table $ TableIn + { _tableIn_headerLabel = headerLabel + , _tableIn_rows = + R.constDyn + . reverse + . L.sortOn _income_date + . _init_incomes + . _incomeIn_init + $ incomeIn + , _tableIn_cell = cell (_incomeIn_init incomeIn) + } + return () + +data Header + = UserHeader + | AmountHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel UserHeader = Msg.get Msg.Income_Name +headerLabel DateHeader = Msg.get Msg.Income_Date +headerLabel AmountHeader = Msg.get Msg.Income_Amount + +cell :: Init -> Header -> Income -> Text +cell init header income = + case header of + UserHeader -> + Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) + + DateHeader -> + Format.longDay . _income_date $ income + + AmountHeader -> + Format.price (_init_currency init) . _income_amount $ income diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs deleted file mode 100644 index 1072a5e..0000000 --- a/client/src/View/Payment.hs +++ /dev/null @@ -1,154 +0,0 @@ -module View.Payment - ( widget - , PaymentIn(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Frequency, Init (..), Payment (..), - PaymentCategory (..), PaymentId, - SavedPayment (..)) -import qualified Common.Util.Text as T -import View.Payment.Header (HeaderIn (..), HeaderOut (..)) -import qualified View.Payment.Header as Header -import View.Payment.Pages (PagesIn (..), PagesOut (..)) -import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..), TableOut (..)) -import qualified View.Payment.Table as Table - -data PaymentIn = PaymentIn - { _paymentIn_init :: Init - } - -widget :: forall t m. MonadWidget t m => PaymentIn -> m () -widget paymentIn = do - R.elClass "main" "payment" $ do - rec - let init = _paymentIn_init paymentIn - - paymentsPerPage = 7 - - addPayment = R.leftmost - [ _headerOut_addPayment header - , _tableOut_addPayment table - ] - - payments <- reducePayments - (_init_payments init) - (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) - - paymentCategories <- reducePaymentCategories - (_init_paymentCategories init) - payments - (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) - - (searchNameEvent, searchName) <- - debounceSearchName (_headerOut_searchName header) - - let searchPayments = - getSearchPayments searchName (_headerOut_searchFrequency header) payments - - header <- Header.widget $ HeaderIn - { _headerIn_init = init - , _headerIn_payments = payments - , _headerIn_searchPayments = searchPayments - , _headerIn_paymentCategories = paymentCategories - } - - table <- Table.widget $ TableIn - { _tableIn_init = init - , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = searchPayments - , _tableIn_perPage = paymentsPerPage - , _tableIn_paymentCategories = paymentCategories - } - - pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> searchPayments - , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = R.leftmost $ - [ () <$ searchNameEvent - , () <$ _headerOut_addPayment header - ] - } - - pure () - -debounceSearchName - :: forall t m. MonadWidget t m - => Dynamic t Text - -> m (Event t Text, Dynamic t Text) -debounceSearchName searchName = do - event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) - dynamic <- R.holdDyn "" event - return (event, dynamic) - -reducePayments - :: forall t m. MonadWidget t m - => [Payment] - -> Event t Payment -- add payment - -> Event t Payment -- edit payment - -> Event t Payment -- delete payment - -> m (Dynamic t [Payment]) -reducePayments initPayments addPayment editPayment deletePayment = - R.foldDyn id initPayments $ R.leftmost - [ (:) <$> addPayment - , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) - , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) - ] - -reducePaymentCategories - :: forall t m. MonadWidget t m - => [PaymentCategory] - -> Dynamic t [Payment] -- payments - -> Event t PaymentCategory -- add payment category - -> Event t PaymentCategory -- edit payment category - -> Event t Payment -- delete payment - -> m (Dynamic t [PaymentCategory]) -reducePaymentCategories - initPaymentCategories - payments - addPaymentCategory - editPaymentCategory - deletePayment - = - R.foldDyn id initPaymentCategories $ R.leftmost - [ (:) <$> addPaymentCategory - , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) - , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) - ] - where - deletePaymentName = - R.attachWithMaybe - (\ps p -> - if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then - Nothing - else - Just (_payment_name p)) - (R.current payments) - deletePayment - lowerName = T.toLower . _payment_name - -getSearchPayments - :: forall t. Reflex t - => Dynamic t Text - -> Dynamic t Frequency - -> Dynamic t [Payment] - -> Dynamic t [Payment] -getSearchPayments name frequency payments = do - n <- name - f <- frequency - ps <- payments - pure $ flip filter ps (\p -> - ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) - && (_payment_frequency p == f) - )) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs new file mode 100644 index 0000000..cfdb441 --- /dev/null +++ b/client/src/View/Payment/Payment.hs @@ -0,0 +1,154 @@ +module View.Payment.Payment + ( view + , PaymentIn(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Frequency, Init (..), Payment (..), + PaymentCategory (..), PaymentId, + SavedPayment (..)) +import qualified Common.Util.Text as T +import View.Payment.Header (HeaderIn (..), HeaderOut (..)) +import qualified View.Payment.Header as Header +import View.Payment.Pages (PagesIn (..), PagesOut (..)) +import qualified View.Payment.Pages as Pages +import View.Payment.Table (TableIn (..), TableOut (..)) +import qualified View.Payment.Table as Table + +data PaymentIn = PaymentIn + { _paymentIn_init :: Init + } + +view :: forall t m. MonadWidget t m => PaymentIn -> m () +view paymentIn = do + R.elClass "main" "payment" $ do + rec + let init = _paymentIn_init paymentIn + + paymentsPerPage = 7 + + addPayment = R.leftmost + [ _headerOut_addPayment header + , _tableOut_addPayment table + ] + + payments <- reducePayments + (_init_payments init) + (_savedPayment_payment <$> addPayment) + (_savedPayment_payment <$> _tableOut_editPayment table) + (_tableOut_deletePayment table) + + paymentCategories <- reducePaymentCategories + (_init_paymentCategories init) + payments + (_savedPayment_paymentCategory <$> addPayment) + (_savedPayment_paymentCategory <$> _tableOut_editPayment table) + (_tableOut_deletePayment table) + + (searchNameEvent, searchName) <- + debounceSearchName (_headerOut_searchName header) + + let searchPayments = + getSearchPayments searchName (_headerOut_searchFrequency header) payments + + header <- Header.widget $ HeaderIn + { _headerIn_init = init + , _headerIn_payments = payments + , _headerIn_searchPayments = searchPayments + , _headerIn_paymentCategories = paymentCategories + } + + table <- Table.widget $ TableIn + { _tableIn_init = init + , _tableIn_currentPage = _pagesOut_currentPage pages + , _tableIn_payments = searchPayments + , _tableIn_perPage = paymentsPerPage + , _tableIn_paymentCategories = paymentCategories + } + + pages <- Pages.widget $ PagesIn + { _pagesIn_total = length <$> searchPayments + , _pagesIn_perPage = paymentsPerPage + , _pagesIn_reset = R.leftmost $ + [ () <$ searchNameEvent + , () <$ _headerOut_addPayment header + ] + } + + pure () + +debounceSearchName + :: forall t m. MonadWidget t m + => Dynamic t Text + -> m (Event t Text, Dynamic t Text) +debounceSearchName searchName = do + event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) + dynamic <- R.holdDyn "" event + return (event, dynamic) + +reducePayments + :: forall t m. MonadWidget t m + => [Payment] + -> Event t Payment -- add payment + -> Event t Payment -- edit payment + -> Event t Payment -- delete payment + -> m (Dynamic t [Payment]) +reducePayments initPayments addPayment editPayment deletePayment = + R.foldDyn id initPayments $ R.leftmost + [ (:) <$> addPayment + , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) + , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) + ] + +reducePaymentCategories + :: forall t m. MonadWidget t m + => [PaymentCategory] + -> Dynamic t [Payment] -- payments + -> Event t PaymentCategory -- add payment category + -> Event t PaymentCategory -- edit payment category + -> Event t Payment -- delete payment + -> m (Dynamic t [PaymentCategory]) +reducePaymentCategories + initPaymentCategories + payments + addPaymentCategory + editPaymentCategory + deletePayment + = + R.foldDyn id initPaymentCategories $ R.leftmost + [ (:) <$> addPaymentCategory + , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) + , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) + ] + where + deletePaymentName = + R.attachWithMaybe + (\ps p -> + if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then + Nothing + else + Just (_payment_name p)) + (R.current payments) + deletePayment + lowerName = T.toLower . _payment_name + +getSearchPayments + :: forall t. Reflex t + => Dynamic t Text + -> Dynamic t Frequency + -> Dynamic t [Payment] + -> Dynamic t [Payment] +getSearchPayments name frequency payments = do + n <- name + f <- frequency + ps <- payments + pure $ flip filter ps (\p -> + ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) + && (_payment_frequency p == f) + )) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 40bc864..bf6b604 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -30,9 +30,6 @@ import qualified View.Payment.Edit as Edit import qualified Icon import qualified Util.Reflex as ReflexUtil --- TODO: remove -import Debug.Trace (trace) - data TableIn t = TableIn { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int -- cgit v1.2.3