From 8c24464a4bd0a486cd0ddf846d3b5a323a7aaa9a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 4 Oct 2015 20:48:32 +0200 Subject: Using incomes to compute a fair computation to designate the payer --- src/client/Main.elm | 13 ++- src/client/Model/Date.elm | 15 ++++ src/client/Model/Income.elm | 76 +++++++++++++++++ src/client/Model/Payer.elm | 129 +++++++++++++++++++++++++++++ src/client/Model/Payers.elm | 59 ------------- src/client/Model/Payment.elm | 4 +- src/client/Model/User.elm | 4 +- src/client/Model/View/LoggedIn/Account.elm | 43 +++++++--- src/client/Model/View/LoggedInView.elm | 10 +-- src/client/ServerCommunication.elm | 17 ++-- src/client/Update.elm | 8 +- src/client/Update/LoggedIn.elm | 12 +-- src/client/Update/LoggedIn/Account.elm | 29 +++++-- src/client/Utils/Dict.elm | 11 +++ src/client/Utils/List.elm | 6 ++ src/client/Utils/Maybe.elm | 20 ++++- src/client/View/LoggedIn/Account.elm | 8 +- src/client/View/LoggedIn/Add.elm | 2 +- src/client/View/LoggedIn/Monthly.elm | 20 +++-- src/client/View/LoggedIn/Table.elm | 4 +- 20 files changed, 361 insertions(+), 129 deletions(-) create mode 100644 src/client/Model/Date.elm create mode 100644 src/client/Model/Income.elm create mode 100644 src/client/Model/Payer.elm delete mode 100644 src/client/Model/Payers.elm create mode 100644 src/client/Utils/Dict.elm create mode 100644 src/client/Utils/List.elm (limited to 'src/client') diff --git a/src/client/Main.elm b/src/client/Main.elm index 621fb97..de98809 100644 --- a/src/client/Main.elm +++ b/src/client/Main.elm @@ -10,11 +10,12 @@ import Http import Task exposing (..) import Time exposing (..) import Json.Decode as Json exposing ((:=)) +import Dict import Model exposing (Model, initialModel) import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder) import Model.Payment exposing (Payments, paymentsDecoder, perPage) -import Model.Payers exposing (Payers, payersDecoder) +import Model.Payer exposing (Payers, payersDecoder) import Model.Translations exposing (..) import Update exposing (Action(..), actions, updateModel) @@ -32,7 +33,7 @@ model = Signal.foldp updateModel (initialModel initialTime translations) update update : Signal Action update = Signal.mergeMany - [ Signal.map UpdateTime (Time.every 30) + [ Signal.map UpdateTime (Time.every 1000) , actions.signal ] @@ -66,8 +67,7 @@ goLoggedInView = Task.andThen getPayments <| \payments -> Task.andThen getPaymentsCount <| \paymentsCount -> Task.andThen getPayers <| \payers -> - Task.andThen getIncome <| \income -> - Signal.send actions.address (GoLoggedInView users me monthlyPayments payments paymentsCount payers income) + Signal.send actions.address (GoLoggedInView users me monthlyPayments payments paymentsCount payers) getUsers : Task Http.Error Users getUsers = Http.get usersDecoder "/users" @@ -85,10 +85,7 @@ getPaymentsCount : Task Http.Error Int getPaymentsCount = Http.get ("number" := Json.int) "/payments/count" getPayers : Task Http.Error Payers -getPayers = Http.get payersDecoder "/payments/total" - -getIncome : Task Http.Error (Maybe Int) -getIncome = Http.get (Json.maybe ("income" := Json.int)) "/income" +getPayers = Http.get payersDecoder "/payers" --------------------------------------- diff --git a/src/client/Model/Date.elm b/src/client/Model/Date.elm new file mode 100644 index 0000000..1c56de4 --- /dev/null +++ b/src/client/Model/Date.elm @@ -0,0 +1,15 @@ +module Model.Date + ( timeDecoder + , dateDecoder + ) where + +import Date as Date exposing (Date) +import Time exposing (Time) + +import Json.Decode as Json exposing (..) + +timeDecoder : Decoder Time +timeDecoder = Json.map Date.toTime dateDecoder + +dateDecoder : Decoder Date +dateDecoder = customDecoder string Date.fromString diff --git a/src/client/Model/Income.elm b/src/client/Model/Income.elm new file mode 100644 index 0000000..ce30772 --- /dev/null +++ b/src/client/Model/Income.elm @@ -0,0 +1,76 @@ +module Model.Income + ( Income + , incomeDecoder + , incomeDefinedForAll + , cumulativeIncomesSince + ) where + +import Json.Decode as Json exposing ((:=)) +import Time exposing (Time, hour) +import List exposing (..) + +import Model.Date exposing (timeDecoder) +import Model.User exposing (UserId) + +import Utils.Maybe exposing (isJust, catMaybes, maybeToList) + +type alias Income = + { creation : Time + , amount : Int + } + +incomeDecoder : Json.Decoder Income +incomeDecoder = + Json.object2 Income + ("creation" := timeDecoder) + ("amount" := Json.int) + +incomeDefinedForAll : List (UserId, List Income) -> Maybe Time +incomeDefinedForAll usersIncomes = + let firstIncomes = map (head << sortBy .creation << snd) usersIncomes + in if all isJust firstIncomes + then head << reverse << List.sort << map .creation << catMaybes <| firstIncomes + else Nothing + +cumulativeIncomesSince : Time -> Time -> (List Income) -> Int +cumulativeIncomesSince currentTime since incomes = + cumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince : Time -> List Income -> List Income +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomesAt time incomes + orderedIncomesSince = filter (\income -> income.creation >= time) incomes + in (maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomesAt : Time -> List Income -> Maybe Income +getIncomesAt time incomes = + case incomes of + [x] -> + if x.creation < time + then Just { creation = time, amount = x.amount } + else Nothing + x1 :: x2 :: xs -> + if x1.creation < time && x2.creation > time + then Just { creation = time, amount = x2.amount } + else getIncomesAt time (x2 :: xs) + [] -> + Nothing + +cumulativeIncome : Time -> List Income -> Int +cumulativeIncome currentTime incomes = + getIncomesWithDuration (incomes ++ [{ creation = currentTime, amount = 0 }]) + |> map durationIncome + |> sum + +getIncomesWithDuration : List Income -> List (Float, Int) +getIncomesWithDuration incomes = + case incomes of + (income1 :: income2 :: xs) -> + (income2.creation - income1.creation, income1.amount) :: (getIncomesWithDuration (income2 :: xs)) + _ -> + [] + +durationIncome : (Float, Int) -> Int +durationIncome (duration, income) = + duration * toFloat income / (hour * 24 * 365 / 12) + |> truncate diff --git a/src/client/Model/Payer.elm b/src/client/Model/Payer.elm new file mode 100644 index 0000000..af475bb --- /dev/null +++ b/src/client/Model/Payer.elm @@ -0,0 +1,129 @@ +module Model.Payer + ( Payers + , Payer + , ExceedingPayer + , payersDecoder + , updatePayers + , getOrderedExceedingPayers + ) where + +import Json.Decode as Json exposing (..) +import Dict exposing (..) +import List +import Maybe +import Time exposing (Time) + +import Model.User exposing (UserId, userIdDecoder) +import Model.Income exposing (..) + +import Utils.Dict exposing (mapValues) +import Utils.Maybe exposing (isJust) + +type alias Payers = Dict UserId Payer + +type alias Payer = + { preIncomePaymentSum : Int + , postIncomePaymentSum : Int + , incomes : List Income + } + +payersDecoder : Decoder Payers +payersDecoder = Json.map Dict.fromList (list payerDecoder) + +payerDecoder : Decoder (UserId, Payer) +payerDecoder = + object2 (,) + ("userId" := userIdDecoder) + (object3 Payer + ("preIncomePaymentSum" := int) + ("postIncomePaymentSum" := int) + ("incomes" := list incomeDecoder)) + +updatePayers : Payers -> UserId -> Time -> Int -> Payers +updatePayers payers userId creation amountDiff = + payers + |> Dict.update userId (\mbPayer -> + case mbPayer of + Just payer -> + let postIncome = + incomeDefinedForAll (Dict.toList << mapValues .incomes <| payers) + |> Maybe.map (\date -> creation > date) + |> Maybe.withDefault False + in if postIncome + then + Just { payer | postIncomePaymentSum <- payer.postIncomePaymentSum + amountDiff } + else + Just { payer | preIncomePaymentSum <- payer.preIncomePaymentSum + amountDiff } + Nothing -> + Nothing + ) + +type alias ExceedingPayer = + { userId : UserId + , amount : Int + } + +getOrderedExceedingPayers : Time -> Payers -> List ExceedingPayer +getOrderedExceedingPayers currentTime payers = + let mbIncomeDefinedForAll = incomeDefinedForAll (Dict.toList << mapValues .incomes <| payers) + exceedingPayersOnPreIncome = + payers + |> mapValues .preIncomePaymentSum + |> Dict.toList + |> exceedingPayersFromAmounts + in case mbIncomeDefinedForAll of + Just since -> + let postPaymentPayers = + payers + |> mapValues (getPostPaymentPayer currentTime since) + mbMaxRatio = + postPaymentPayers + |> Dict.toList + |> List.map (.ratio << snd) + |> List.maximum + in case mbMaxRatio of + Just maxRatio -> + postPaymentPayers + |> mapValues (getFinalDiff maxRatio) + |> Dict.toList + |> exceedingPayersFromAmounts + Nothing -> + exceedingPayersOnPreIncome + Nothing -> + exceedingPayersOnPreIncome + +exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer +exceedingPayersFromAmounts userAmounts = + let mbMinAmount = List.minimum << List.map snd <| userAmounts + in case mbMinAmount of + Nothing -> + [] + Just minAmount -> + userAmounts + |> List.map (\userAmount -> + { userId = fst userAmount + , amount = snd userAmount - minAmount + } + ) + |> List.filter (\payer -> payer.amount > 0) + +type alias PostPaymentPayer = + { preIncomePaymentSum : Int + , cumulativeIncome : Int + , ratio : Float + } + +getPostPaymentPayer : Time -> Time -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + let cumulativeIncome = cumulativeIncomesSince currentTime since payer.incomes + in { preIncomePaymentSum = payer.preIncomePaymentSum + , cumulativeIncome = cumulativeIncome + , ratio = toFloat payer.postIncomePaymentSum / toFloat cumulativeIncome + } + +getFinalDiff : Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + -1 * (maxRatio - payer.ratio) * toFloat payer.cumulativeIncome + |> truncate + in postIncomeDiff + payer.preIncomePaymentSum diff --git a/src/client/Model/Payers.elm b/src/client/Model/Payers.elm deleted file mode 100644 index 983e7b3..0000000 --- a/src/client/Model/Payers.elm +++ /dev/null @@ -1,59 +0,0 @@ -module Model.Payers - ( Payers - , ExceedingPayer - , payersDecoder - , updatePayers - , getOrderedExceedingPayers - ) where - -import Json.Decode as Json exposing (..) -import Dict exposing (..) -import List -import Maybe - -import Model.User exposing (UserId, userIdDecoder) - -type alias Payers = Dict UserId Int - -payersDecoder : Decoder Payers -payersDecoder = Json.map Dict.fromList (list payerDecoder) - -payerDecoder : Decoder (UserId, Int) -payerDecoder = - object2 (,) - ("userId" := userIdDecoder) - ("totalPayment" := int) - -updatePayers : Payers -> UserId -> Int -> Payers -updatePayers payers userId amountDiff = - Dict.update - userId - (\mbAmount -> - case mbAmount of - Just amount -> Just (amount + amountDiff) - Nothing -> Nothing - ) - payers - -type alias ExceedingPayer = - { userId : UserId - , amount : Int - } - -getOrderedExceedingPayers : Payers -> List ExceedingPayer -getOrderedExceedingPayers payers = - let orderedPayers = - Dict.toList payers - |> List.map (\(userId, amount) -> ExceedingPayer userId amount) - |> List.sortBy .amount - maybeMinAmount = - List.head orderedPayers - |> Maybe.map .amount - in case maybeMinAmount of - Just minAmount -> - orderedPayers - |> List.map (\payer -> { payer | amount <- payer.amount - minAmount }) - |> List.filter (\payer -> payer.amount /= 0) - |> List.reverse - Nothing -> - [] diff --git a/src/client/Model/Payment.elm b/src/client/Model/Payment.elm index 1f1c4ed..c4a8963 100644 --- a/src/client/Model/Payment.elm +++ b/src/client/Model/Payment.elm @@ -11,6 +11,7 @@ import Date exposing (..) import Json.Decode as Json exposing ((:=)) import Model.User exposing (UserId, userIdDecoder) +import Model.Date exposing (dateDecoder) perPage : Int perPage = 8 @@ -41,6 +42,3 @@ paymentDecoder = paymentIdDecoder : Json.Decoder PaymentId paymentIdDecoder = Json.int - -dateDecoder : Json.Decoder Date -dateDecoder = Json.customDecoder Json.string Date.fromString diff --git a/src/client/Model/User.elm b/src/client/Model/User.elm index b0d62a6..1412913 100644 --- a/src/client/Model/User.elm +++ b/src/client/Model/User.elm @@ -25,7 +25,9 @@ usersDecoder = Json.map Dict.fromList (Json.list userWithIdDecoder) userWithIdDecoder : Json.Decoder (UserId, User) userWithIdDecoder = - userDecoder `Json.andThen` (\user -> Json.map (\id -> (id, user)) ("id" := userIdDecoder)) + Json.object2 (,) + ("id" := userIdDecoder) + userDecoder userDecoder : Json.Decoder User userDecoder = diff --git a/src/client/Model/View/LoggedIn/Account.elm b/src/client/Model/View/LoggedIn/Account.elm index 7f0fbe3..ab37b81 100644 --- a/src/client/Model/View/LoggedIn/Account.elm +++ b/src/client/Model/View/LoggedIn/Account.elm @@ -3,36 +3,57 @@ module Model.View.LoggedIn.Account , IncomeEdition , initAccount , initIncomeEdition + , getCurrentIncome , validateIncome ) where import Result as Result exposing (Result(..)) +import Dict import Utils.Validation exposing (..) +import Utils.Dict exposing (mapValues) import Model.Translations exposing (..) -import Model.Payers exposing (..) +import Model.Payer exposing (..) +import Model.User exposing (UserId) type alias Account = - { payers : Payers - , income : Maybe Int + { me : UserId + , payers : Payers , visibleDetail : Bool , incomeEdition : Maybe IncomeEdition } +initAccount : UserId -> Payers -> Account +initAccount me payers = + { me = me + , payers = + payers + |> mapValues + (\payer -> + { payer | incomes <- List.sortBy .creation payer.incomes } + ) + , visibleDetail = False + , incomeEdition = Nothing + } + +getCurrentIncome : Account -> Maybe Int +getCurrentIncome account = + case Dict.get account.me account.payers of + Just payer -> + payer.incomes + |> List.sortBy .creation + |> List.reverse + |> List.head + |> Maybe.map .amount + Nothing -> + Nothing + type alias IncomeEdition = { income : String , error : Maybe String } -initAccount : Payers -> Maybe Int -> Account -initAccount payers income = - { payers = payers - , income = income - , visibleDetail = False - , incomeEdition = Nothing - } - initIncomeEdition : Int -> IncomeEdition initIncomeEdition income = { income = toString income diff --git a/src/client/Model/View/LoggedInView.elm b/src/client/Model/View/LoggedInView.elm index 12a7294..122c4be 100644 --- a/src/client/Model/View/LoggedInView.elm +++ b/src/client/Model/View/LoggedInView.elm @@ -5,7 +5,7 @@ module Model.View.LoggedInView import Model.User exposing (Users, UserId) import Model.Payment exposing (Payments) -import Model.Payers exposing (Payers) +import Model.Payer exposing (Payers) import Model.View.LoggedIn.Add exposing (..) import Model.View.LoggedIn.Edition exposing (..) import Model.View.LoggedIn.Monthly exposing (..) @@ -13,7 +13,6 @@ import Model.View.LoggedIn.Account exposing (..) type alias LoggedInView = { users : Users - , me : UserId , add : AddPayment , monthly : Monthly , account : Account @@ -23,13 +22,12 @@ type alias LoggedInView = , currentPage : Int } -initLoggedInView : Users -> UserId -> Payments -> Payments -> Int -> Payers -> Maybe Int -> LoggedInView -initLoggedInView users me monthlyPayments payments paymentsCount payers income = +initLoggedInView : Users -> UserId -> Payments -> Payments -> Int -> Payers -> LoggedInView +initLoggedInView users me monthlyPayments payments paymentsCount payers = { users = users - , me = me , add = initAddPayment Punctual , monthly = initMonthly monthlyPayments - , account = initAccount payers income + , account = initAccount me payers , payments = payments , paymentsCount = paymentsCount , paymentEdition = Nothing diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm index 47d8c27..55bf947 100644 --- a/src/client/ServerCommunication.elm +++ b/src/client/ServerCommunication.elm @@ -9,6 +9,7 @@ import Task as Task exposing (Task) import Http import Json.Decode exposing (..) import Date +import Time exposing (Time) import Model.User exposing (UserId) import Model.Payment exposing (..) @@ -25,8 +26,8 @@ type Communication = | SignIn String | AddPayment UserId String Int | AddMonthlyPayment String Int - | SetIncome Int - | DeletePayment PaymentId UserId Int Int + | SetIncome Time Int + | DeletePayment Payment Int | DeleteMonthlyPayment PaymentId | UpdatePage Int | SignOut @@ -50,8 +51,8 @@ getRequest communication = SignIn login -> Just (simple "post" ("/signIn?login=" ++ login)) AddPayment userId name cost -> Just (addPaymentRequest name cost Punctual) AddMonthlyPayment name cost -> Just (addPaymentRequest name cost Monthly) - SetIncome amount -> Just (simple "post" ("/income?amount=" ++ (toString amount))) - DeletePayment paymentId _ _ _ -> Just (deletePaymentRequest paymentId) + SetIncome _ amount -> Just (simple "post" ("/income?amount=" ++ (toString amount))) + DeletePayment payment _ -> Just (deletePaymentRequest payment.id) DeleteMonthlyPayment paymentId -> Just (deletePaymentRequest paymentId) UpdatePage page -> Just (updatePageRequest page) SignOut -> Just (simple "post" "/signOut") @@ -95,12 +96,12 @@ serverResult communication response = ("id" := paymentIdDecoder) (\id -> Task.succeed <| U.UpdateLoggedIn (UL.AddMonthlyPayment id name cost)) response - SetIncome amount -> - Task.succeed <| U.UpdateLoggedIn (UL.UpdateAccount (UA.UpdateIncome amount)) - DeletePayment id userId cost currentPage -> + SetIncome currentTime amount -> + Task.succeed <| U.UpdateLoggedIn (UL.UpdateAccount (UA.UpdateIncome currentTime amount)) + DeletePayment payment currentPage -> Http.send Http.defaultSettings (updatePageRequest currentPage) |> flip Task.andThen (decodeOkResponse paymentsDecoder (\payments -> - Task.succeed <| U.UpdateLoggedIn (UL.DeletePayment userId cost payments) + Task.succeed <| U.UpdateLoggedIn (UL.DeletePayment payment payments) )) DeleteMonthlyPayment id -> Task.succeed <| U.UpdateLoggedIn (UL.UpdateMonthly (UM.DeletePayment id)) diff --git a/src/client/Update.elm b/src/client/Update.elm index 4389140..3c4614a 100644 --- a/src/client/Update.elm +++ b/src/client/Update.elm @@ -9,7 +9,7 @@ import Time exposing (Time) import Model exposing (Model) import Model.User exposing (Users, UserId) import Model.Payment exposing (Payments) -import Model.Payers exposing (Payers) +import Model.Payer exposing (Payers) import Model.View as V import Model.View.SignInView exposing (..) import Model.View.LoggedInView exposing (..) @@ -23,7 +23,7 @@ type Action = | GoSignInView | SignInError String | UpdateSignIn SignInAction - | GoLoggedInView Users UserId Payments Payments Int Payers (Maybe Int) + | GoLoggedInView Users UserId Payments Payments Int Payers | UpdateLoggedIn LoggedAction actions : Signal.Mailbox Action @@ -38,8 +38,8 @@ updateModel action model = { model | currentTime <- time } GoSignInView -> { model | view <- V.SignInView initSignInView } - GoLoggedInView users me monthlyPayments payments paymentsCount payers mbIncome -> - { model | view <- V.LoggedInView (initLoggedInView users me monthlyPayments payments paymentsCount payers mbIncome) } + GoLoggedInView users me monthlyPayments payments paymentsCount payers -> + { model | view <- V.LoggedInView (initLoggedInView users me monthlyPayments payments paymentsCount payers) } SignInError msg -> let signInView = { initSignInView | result <- Just (Err msg) } in { model | view <- V.SignInView signInView } diff --git a/src/client/Update/LoggedIn.elm b/src/client/Update/LoggedIn.elm index 07f3426..e200b04 100644 --- a/src/client/Update/LoggedIn.elm +++ b/src/client/Update/LoggedIn.elm @@ -16,13 +16,15 @@ import Update.LoggedIn.Add exposing (..) import Update.LoggedIn.Monthly as UM import Update.LoggedIn.Account as UA +import Utils.List exposing (find) + type LoggedAction = UpdateAdd AddPaymentAction | UpdatePayments Payments | AddPayment UserId String Int Payments | AddMonthlyPayment PaymentId String Int | ToggleEdit PaymentId - | DeletePayment UserId Int Payments + | DeletePayment Payment Payments | UpdatePage Int Payments | UpdateMonthly UM.MonthlyAction | UpdateAccount UA.AccountAction @@ -39,22 +41,22 @@ updateLoggedIn model action loggedInView = | payments <- payments , currentPage <- 1 , add <- initAddPayment Punctual - , account <- UA.updateAccount (UA.UpdatePayer userId cost) loggedInView.account + , account <- UA.updateAccount (UA.UpdatePayer userId model.currentTime cost) loggedInView.account , paymentsCount <- loggedInView.paymentsCount + 1 } AddMonthlyPayment id name cost -> { loggedInView | add <- initAddPayment Monthly , monthly <- - let payment = Payment id (Date.fromTime model.currentTime) name cost loggedInView.me + let payment = Payment id (Date.fromTime model.currentTime) name cost loggedInView.account.me in UM.updateMonthly (UM.AddPayment payment) loggedInView.monthly } ToggleEdit id -> { loggedInView | paymentEdition <- if loggedInView.paymentEdition == Just id then Nothing else Just id } - DeletePayment userId cost payments -> + DeletePayment payment payments -> { loggedInView | payments <- payments - , account <- UA.updateAccount (UA.UpdatePayer userId -cost) loggedInView.account + , account <- UA.updateAccount (UA.UpdatePayer payment.userId (Date.toTime payment.creation) -payment.cost) loggedInView.account , paymentsCount <- loggedInView.paymentsCount - 1 } UpdatePage page payments -> diff --git a/src/client/Update/LoggedIn/Account.elm b/src/client/Update/LoggedIn/Account.elm index 2d9cd87..cf4c834 100644 --- a/src/client/Update/LoggedIn/Account.elm +++ b/src/client/Update/LoggedIn/Account.elm @@ -4,33 +4,35 @@ module Update.LoggedIn.Account ) where import Maybe +import Time exposing (Time) +import Dict import Model.User exposing (UserId) -import Model.Payers exposing (..) +import Model.Payer exposing (..) import Model.View.LoggedIn.Account exposing (..) import Utils.Maybe exposing (isJust) type AccountAction = ToggleDetail - | UpdatePayer UserId Int + | UpdatePayer UserId Time Int | ToggleIncomeEdition | UpdateIncomeEdition String | UpdateEditionError String - | UpdateIncome Int + | UpdateIncome Time Int updateAccount : AccountAction -> Account -> Account updateAccount action account = case action of ToggleDetail -> { account | visibleDetail <- not account.visibleDetail } - UpdatePayer userId cost -> - { account | payers <- updatePayers account.payers userId cost } + UpdatePayer userId creation amountDiff -> + { account | payers <- updatePayers account.payers userId creation amountDiff } ToggleIncomeEdition -> { account | incomeEdition <- if isJust account.incomeEdition then Nothing - else Just (initIncomeEdition (Maybe.withDefault 0 account.income)) + else Just (initIncomeEdition (Maybe.withDefault 0 (getCurrentIncome account))) } UpdateIncomeEdition income -> case account.incomeEdition of @@ -44,8 +46,19 @@ updateAccount action account = { account | incomeEdition <- Just { incomeEdition | error <- Just error } } Nothing -> account - UpdateIncome amount -> + UpdateIncome currentTime amount -> { account - | income <- Just amount + | payers <- + account.payers + |> Dict.update account.me (\mbPayer -> + case mbPayer of + Just payer -> + Just + { payer + | incomes <- payer.incomes ++ [{ creation = currentTime, amount = amount }] + } + Nothing -> + Nothing + ) , incomeEdition <- Nothing } diff --git a/src/client/Utils/Dict.elm b/src/client/Utils/Dict.elm new file mode 100644 index 0000000..dc01b17 --- /dev/null +++ b/src/client/Utils/Dict.elm @@ -0,0 +1,11 @@ +module Utils.Dict + ( mapValues + ) where + +import Dict as Dict exposing (..) + +mapValues : (a -> b) -> Dict comparable a -> Dict comparable b +mapValues f = Dict.fromList << List.map (onSecond f) << Dict.toList + +onSecond : (a -> b) -> (comparable, a) -> (comparable, b) +onSecond f tuple = case tuple of (x, y) -> (x, f y) diff --git a/src/client/Utils/List.elm b/src/client/Utils/List.elm new file mode 100644 index 0000000..f33e124 --- /dev/null +++ b/src/client/Utils/List.elm @@ -0,0 +1,6 @@ +module Utils.List + ( find + ) where + +find : (a -> Bool) -> List a -> Maybe a +find predicate = List.head << List.filter predicate diff --git a/src/client/Utils/Maybe.elm b/src/client/Utils/Maybe.elm index 507d9a4..d954ae0 100644 --- a/src/client/Utils/Maybe.elm +++ b/src/client/Utils/Maybe.elm @@ -1,9 +1,27 @@ module Utils.Maybe ( isJust + , catMaybes + , maybeToList ) where isJust : Maybe a -> Bool isJust maybe = case maybe of - Just _ -> True + Just _ -> True Nothing -> False + +catMaybes : List (Maybe a) -> List a +catMaybes = + List.foldr + (\mb xs -> + case mb of + Just x -> x :: xs + Nothing -> xs + ) + [] + +maybeToList : Maybe a -> List a +maybeToList mb = + case mb of + Just a -> [a] + Nothing -> [] diff --git a/src/client/View/LoggedIn/Account.elm b/src/client/View/LoggedIn/Account.elm index 7e383f3..706f7cc 100644 --- a/src/client/View/LoggedIn/Account.elm +++ b/src/client/View/LoggedIn/Account.elm @@ -16,7 +16,7 @@ import Update.LoggedIn.Account exposing (..) import Model exposing (Model) import Model.User exposing (getUserName) -import Model.Payers exposing (..) +import Model.Payer exposing (..) import Model.View.LoggedInView exposing (LoggedInView) import Model.Translations exposing (getParamMessage, getMessage) import Model.View.LoggedIn.Account exposing (..) @@ -48,7 +48,7 @@ exceedingPayers model loggedInView = [ class "header" , onClick actions.address (UpdateLoggedIn << UpdateAccount <| ToggleDetail) ] - ( (List.map (exceedingPayer model loggedInView) (getOrderedExceedingPayers loggedInView.account.payers)) + ( (List.map (exceedingPayer model loggedInView) (getOrderedExceedingPayers model.currentTime loggedInView.account.payers)) ++ [ expand ExpandDown loggedInView.account.visibleDetail ] ) @@ -80,7 +80,7 @@ incomeRead : Model -> Account -> Html incomeRead model account = div [ class "income" ] - [ ( case account.income of + [ ( case getCurrentIncome account of Nothing -> text (getMessage "NoIncome" model.translations) Just income -> @@ -94,7 +94,7 @@ incomeEdition model account edition = H.form [ case validateIncome edition.income model.translations of Ok validatedAmount -> - onSubmitPrevDefault serverCommunications.address (SC.SetIncome validatedAmount) + onSubmitPrevDefault serverCommunications.address (SC.SetIncome model.currentTime validatedAmount) Err error -> onSubmitPrevDefault actions.address (UpdateLoggedIn << UpdateAccount << UpdateEditionError <| error) , class "income" diff --git a/src/client/View/LoggedIn/Add.elm b/src/client/View/LoggedIn/Add.elm index 2167a7f..52d931a 100644 --- a/src/client/View/LoggedIn/Add.elm +++ b/src/client/View/LoggedIn/Add.elm @@ -32,7 +32,7 @@ addPayment model loggedInView = (Ok name, Ok cost) -> let action = case loggedInView.add.frequency of - Punctual -> SC.AddPayment loggedInView.me name cost + Punctual -> SC.AddPayment loggedInView.account.me name cost Monthly -> SC.AddMonthlyPayment name cost in onSubmitPrevDefault serverCommunications.address action (resName, resCost) -> diff --git a/src/client/View/LoggedIn/Monthly.elm b/src/client/View/LoggedIn/Monthly.elm index 9195479..a274015 100644 --- a/src/client/View/LoggedIn/Monthly.elm +++ b/src/client/View/LoggedIn/Monthly.elm @@ -27,15 +27,19 @@ import View.Price exposing (price) monthlyPayments : Model -> LoggedInView -> Html monthlyPayments model loggedInView = let monthly = loggedInView.monthly - in div - [ classList - [ ("monthlyPayments", True) - , ("detail", monthly.visibleDetail) + in if List.length monthly.payments == 0 + then + text "" + else + div + [ classList + [ ("monthlyPayments", True) + , ("detail", monthly.visibleDetail) + ] + ] + [ monthlyCount model monthly + , if monthly.visibleDetail then paymentsTable model loggedInView monthly else text "" ] - ] - [ monthlyCount model monthly - , if monthly.visibleDetail then paymentsTable model loggedInView monthly else text "" - ] monthlyCount : Model -> Monthly -> Html monthlyCount model monthly = diff --git a/src/client/View/LoggedIn/Table.elm b/src/client/View/LoggedIn/Table.elm index d98cee6..9d28e81 100644 --- a/src/client/View/LoggedIn/Table.elm +++ b/src/client/View/LoggedIn/Table.elm @@ -84,12 +84,12 @@ paymentLine model loggedInView payment = [ class "longDate" ] [ text (renderLongDate payment.creation model.translations) ] ] - , if loggedInView.me == payment.userId + , if loggedInView.account.me == payment.userId then div [ class "cell delete" ] [ button - [ onClick serverCommunications.address (SC.DeletePayment payment.id payment.userId payment.cost loggedInView.currentPage) ] + [ onClick serverCommunications.address (SC.DeletePayment payment loggedInView.currentPage) ] [ renderIcon "times" ] ] else -- cgit v1.2.3