aboutsummaryrefslogtreecommitdiff
path: root/client
diff options
context:
space:
mode:
Diffstat (limited to 'client')
-rw-r--r--client/client.cabal5
-rw-r--r--client/src/View/Payment/Header.hs187
-rw-r--r--client/src/View/Payment/HeaderForm.hs78
-rw-r--r--client/src/View/Payment/HeaderInfos.hs96
-rw-r--r--client/src/View/Payment/Init.hs13
-rw-r--r--client/src/View/Payment/Payment.hs53
6 files changed, 206 insertions, 226 deletions
diff --git a/client/client.cabal b/client/client.cabal
index 75c2c1b..78ea7d3 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -61,7 +61,6 @@ Executable client
Util.Ajax
Util.Css
Util.Either
- Util.List
Util.Reflex
Util.Router
Util.Validation
@@ -76,8 +75,8 @@ Executable client
View.Income.Table
View.NotFound
View.Payment.Form
- View.Payment.Header
- View.Payment.Init
+ View.Payment.HeaderForm
+ View.Payment.HeaderInfos
View.Payment.Payment
View.Payment.Reducer
View.Payment.Table
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
deleted file mode 100644
index c8ca347..0000000
--- a/client/src/View/Payment/Header.hs
+++ /dev/null
@@ -1,187 +0,0 @@
-module View.Payment.Header
- ( view
- , In(..)
- , Out(..)
- ) where
-
-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 Data.Time (NominalDiffTime)
-import qualified Data.Time as Time
-import qualified Data.Validation as V
-import Prelude hiding (init)
-import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
-import qualified Reflex.Dom as R
-
-import Common.Model (Category, Currency,
- ExceedingPayer (..), Frequency (..),
- Income (..), Payment (..),
- PaymentCategory, SavedPayment (..),
- User (..))
-import qualified Common.Model as CM
-import qualified Common.Msg as Msg
-import qualified Common.View.Format as Format
-
-import qualified Component.Button as Button
-import qualified Component.Input as Input
-import qualified Component.Modal as Modal
-import qualified Component.Select as Select
-import qualified Util.List as L
-import qualified View.Payment.Form as Form
-import View.Payment.Init (Init (..))
-
-data In t = In
- { _in_init :: Init
- , _in_currency :: Currency
- , _in_payments :: Dynamic t [Payment]
- , _in_searchPayments :: Dynamic t [Payment]
- , _in_paymentCategories :: Dynamic t [PaymentCategory]
- }
-
-data Out t = Out
- { _out_searchName :: Dynamic t Text
- , _out_searchFrequency :: Dynamic t Frequency
- , _out_addPayment :: Event t SavedPayment
- }
-
-view :: forall t m. MonadWidget t m => In t -> m (Out t)
-view input =
- R.divClass "header" $ do
- rec
- addPayment <-
- payerAndAdd
- incomes
- payments
- users
- categories
- paymentCategories
- currency
- searchFrequency
- let resetSearchName = fmap (const ()) $ addPayment
- (searchName, searchFrequency) <- searchLine resetSearchName
-
- infos (_in_searchPayments input) users currency
-
- return $ Out
- { _out_searchName = searchName
- , _out_searchFrequency = searchFrequency
- , _out_addPayment = addPayment
- }
- where
- init = _in_init input
- incomes = _init_incomes init
- initPayments = _init_payments init
- payments = _in_payments input
- users = _init_users init
- categories = _init_categories init
- currency = _in_currency input
- paymentCategories = _in_paymentCategories input
-
-payerAndAdd
- :: forall t m. MonadWidget t m
- => [Income]
- -> Dynamic t [Payment]
- -> [User]
- -> [Category]
- -> Dynamic t [PaymentCategory]
- -> Currency
- -> Dynamic t Frequency
- -> m (Event t SavedPayment)
-payerAndAdd incomes payments users categories paymentCategories currency frequency = do
- time <- liftIO Time.getCurrentTime
- R.divClass "payerAndAdd" $ do
-
- let exceedingPayers =
- R.ffor payments $ \ps ->
- CM.getExceedingPayers time users incomes $
- filter ((==) Punctual . _payment_frequency) ps
-
- R.divClass "exceedingPayers" $
- R.simpleList exceedingPayers $ \exceedingPayer ->
- R.elClass "span" "exceedingPayer" $ do
- R.elClass "span" "userName" $
- R.dynText . R.ffor exceedingPayer $ \ep ->
- fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users
- R.elClass "span" "amount" $ do
- R.text "+ "
- R.dynText . R.ffor exceedingPayer $ \ep ->
- Format.price currency $ _exceedingPayer_amount ep
-
- addPayment <- Button._out_clic <$>
- (Button.view $
- (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add))
- { Button._in_class = R.constDyn "addPayment"
- })
-
- Modal.view $ Modal.In
- { Modal._in_show = addPayment
- , Modal._in_content = \_ -> return (R.never, R.never) -- TODO
- }
-
-searchLine
- :: forall t m. MonadWidget t m
- => Event t ()
- -> m (Dynamic t Text, Dynamic t Frequency)
-searchLine reset = do
- R.divClass "searchLine" $ do
- searchName <- Input._out_raw <$> (Input.view
- ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
- ("" <$ reset)
- R.never)
-
- let frequencies = M.fromList
- [ (Punctual, Msg.get Msg.Payment_PunctualMale)
- , (Monthly, Msg.get Msg.Payment_MonthlyMale)
- ]
-
- searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
- { Select._in_label = ""
- , Select._in_initialValue = Punctual
- , Select._in_value = R.never
- , Select._in_values = R.constDyn frequencies
- , Select._in_reset = R.never
- , Select._in_isValid = V.Success
- , Select._in_validate = R.never
- })
-
- 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.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)
-
- 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/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs
new file mode 100644
index 0000000..07a6b81
--- /dev/null
+++ b/client/src/View/Payment/HeaderForm.hs
@@ -0,0 +1,78 @@
+module View.Payment.HeaderForm
+ ( view
+ ) where
+
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Validation as V
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Category, Currency, ExceedingPayer (..),
+ Frequency (..), Income (..), Payment (..),
+ PaymentCategory, SavedPayment (..),
+ User (..))
+import qualified Common.Msg as Msg
+
+import qualified Component.Button as Button
+import qualified Component.Input as Input
+import qualified Component.Modal as Modal
+import qualified Component.Select as Select
+import qualified View.Payment.Form as Form
+
+data In t = In
+ { _in_reset :: Event t ()
+ , _in_categories :: [Category]
+ , _in_paymentCategories :: [PaymentCategory]
+ }
+
+data Out = Out
+ { _out_name :: Event t Text
+ , _out_frequency :: Event t Frequency
+ , _out_addPayment :: Event t SavedPayment
+ }
+
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input = do
+ R.divClass "g-HeaderForm" $ do
+ searchName <- Input._out_raw <$> (Input.view
+ ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
+ ("" <$ _in_reset input)
+ R.never)
+
+ let frequencies = M.fromList
+ [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+ , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+ ]
+
+ searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
+ { Select._in_label = ""
+ , Select._in_initialValue = Punctual
+ , Select._in_value = R.never
+ , Select._in_values = R.constDyn frequencies
+ , Select._in_reset = R.never
+ , Select._in_isValid = V.Success
+ , Select._in_validate = R.never
+ })
+
+ addPaymentButton <- Button._out_clic <$>
+ (Button.view $
+ (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add))
+ { Button._in_class = R.constDyn "addPayment"
+ })
+
+ addPayment <- Modal.view $ Modal.In
+ { Modal._in_show = addPaymentButton
+ , Modal._in_content =
+ Form.view $ Form.In
+ { Form._in_categories = _in_categories input
+ , Form._in_paymentCategories = _in_paymentCategories input
+ , Form._in_operation = Form.New searchFrequency
+ }
+ }
+
+ return $ Out
+ { _out_name = searchName
+ , _out_frequency = searchFrequency
+ , _out_addPayment = addPayment
+ }
diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs
new file mode 100644
index 0000000..12facc4
--- /dev/null
+++ b/client/src/View/Payment/HeaderInfos.hs
@@ -0,0 +1,96 @@
+module View.Payment.HeaderInfos
+ ( view
+ , In(..)
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.List as L hiding (groupBy)
+import Data.Map (Map)
+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 Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Currency, ExceedingPayer (..),
+ Payment (..), PaymentHeader (..),
+ SavedPayment (..), User (..), UserId)
+import qualified Common.Model as CM
+import qualified Common.Msg as Msg
+import qualified Common.View.Format as Format
+
+import qualified Util.List as L
+
+data In t = In
+ { _in_users :: [User]
+ , _in_currency :: Currency
+ , _in_header :: PaymentHeader
+ , _in_paymentCount :: Int
+ }
+
+view :: forall t m. MonadWidget t m => In t -> m ()
+view input =
+ R.divClass "g-HeaderInfos" $ do
+ exceedingPayers
+ (_in_users input)
+ (_in_currency input)
+ (_paymentHeader_exceedingPayers header)
+
+ infos
+ (_in_users input)
+ (_in_currency input)
+ (_paymentHeader_repartition header)
+ (_in_paymentCount input)
+
+ where
+ header = _in_header input
+
+exceedingPayers
+ :: forall t m. MonadWidget t m
+ => [User]
+ -> Currency
+ -> [ExceedingPayer]
+ -> m ()
+exceedingPayers users currency payers =
+ R.divClass "g-HeaderInfos__ExceedingPayers" $
+ flip mapM_ payers $ \payer ->
+ R.elClass "span" "exceedingPayer" $ do
+ R.elClass "span" "userName" $
+ R.text $
+ fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId payer) users
+ R.elClass "span" "amount" $ do
+ R.text "+ "
+ R.text . Format.price currency $ _exceedingPayer_amount payer
+
+infos
+ :: forall t m. MonadWidget t m
+ => [User]
+ -> Currency
+ -> Map UserId Int
+ -> Int
+ -> m ()
+infos users currency repartition paymentCount =
+ R.divClass "g-HeaderInfos__Repartition" $ 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 (M.foldl (+) 0 repartition))
+
+ R.elClass "span" "partition" . R.text $
+ let totalByUser =
+ L.sortBy (\(_, t1) (_, t2) -> compare t2 t1)
+ . M.toList
+ $ repartition
+ in 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/client/src/View/Payment/Init.hs b/client/src/View/Payment/Init.hs
deleted file mode 100644
index d9f85c8..0000000
--- a/client/src/View/Payment/Init.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module View.Payment.Init
- ( Init(..)
- ) where
-
-import Common.Model (Category, Income, Payment, PaymentCategory, User)
-
-data Init = Init
- { _init_users :: [User]
- , _init_payments :: [Payment]
- , _init_incomes :: [Income]
- , _init_categories :: [Category]
- , _init_paymentCategories :: [PaymentCategory]
- } deriving (Show)
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index bf0186f..f47b627 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -3,29 +3,29 @@ module View.Payment.Payment
, In(..)
) where
-import qualified Data.Maybe as Maybe
-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 (Currency, Frequency, Income (..),
- Payment (..), PaymentCategory (..),
- PaymentId, PaymentPage (..),
- SavedPayment (..), User, UserId)
-import qualified Common.Util.Text as T
-
-import qualified Component.Pages as Pages
-import Loadable (Loadable (..))
+import qualified Data.Maybe as Maybe
+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 (Currency, Frequency, Income (..),
+ Payment (..), PaymentCategory (..),
+ PaymentId, PaymentPage (..),
+ SavedPayment (..), User, UserId)
+import qualified Common.Util.Text as T
+
+import qualified Component.Pages as Pages
+import Loadable (Loadable (..))
import qualified Loadable
-import qualified Util.Ajax as AjaxUtil
-import qualified Util.Reflex as ReflexUtil
-import qualified View.Payment.Header as Header
-import View.Payment.Init (Init (..))
-import qualified View.Payment.Reducer as Reducer
-import qualified View.Payment.Table as Table
+import qualified Util.Ajax as AjaxUtil
+import qualified Util.Reflex as ReflexUtil
+import qualified View.Payment.HeaderInfos as HeaderInfos
+-- import qualified View.Payment.HeaderForm as HeaderForm
+import qualified View.Payment.Reducer as Reducer
+import qualified View.Payment.Table as Table
data In t = In
{ _in_currentUser :: UserId
@@ -61,7 +61,14 @@ view input = do
deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) ->
- flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do
+ flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do
+ HeaderInfos.view $ HeaderInfos.In
+ { HeaderInfos._in_users = _in_users input
+ , HeaderInfos._in_currency = _in_currency input
+ , HeaderInfos._in_header = header
+ , HeaderInfos._in_paymentCount = count
+ }
+
table <- Table.view $ Table.In
{ Table._in_users = _in_users input
, Table._in_currentUser = _in_currentUser input
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:38:02 +0000