diff options
Diffstat (limited to 'client/src/View/Payment')
| -rw-r--r-- | client/src/View/Payment/Header.hs | 187 | ||||
| -rw-r--r-- | client/src/View/Payment/HeaderForm.hs | 78 | ||||
| -rw-r--r-- | client/src/View/Payment/HeaderInfos.hs | 96 | ||||
| -rw-r--r-- | client/src/View/Payment/Init.hs | 13 | ||||
| -rw-r--r-- | client/src/View/Payment/Payment.hs | 53 |
5 files changed, 204 insertions, 223 deletions
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 |