From bab2c30addf8aaed85675e2b7f7b15c97c426f74 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 15:00:07 +0100 Subject: Add exceeding payer block --- client/src/Component/Button.hs | 6 -- client/src/Icon.hs | 4 +- client/src/View/Payment.hs | 8 +- client/src/View/Payment/Header.hs | 66 ++++++++---- common/common.cabal | 1 + common/src/Common/Model.hs | 1 + common/src/Common/Model/Payer.hs | 198 ++++++++++++++++++++++++++++++++++ server/server.cabal | 1 - server/src/Design/View/Header.hs | 2 +- server/src/Main.hs | 4 +- server/src/Model/Payer.hs | 217 -------------------------------------- 11 files changed, 258 insertions(+), 250 deletions(-) create mode 100644 common/src/Common/Model/Payer.hs delete mode 100644 server/src/Model/Payer.hs diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 09c93cd..754b903 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -48,9 +48,3 @@ button buttonIn = do return $ ButtonOut { _buttonOut_clic = R.domEvent R.Click e } - --- mergeAttr :: Map Text Text -> Map Text Text -> Map Text Text --- mergeAttr = M.unionWithKey $ \k a b -> --- if k == "class" --- then T.intercalate " " [ a, b ] --- else b diff --git a/client/src/Icon.hs b/client/src/Icon.hs index fbf5388..e04e2a8 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -58,8 +58,8 @@ loading = signOut :: forall t m. MonadWidget t m => m () signOut = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank + svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 934f720..15892c4 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -4,6 +4,7 @@ module View.Payment , PaymentOut(..) ) where +import Prelude hiding (init) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R @@ -29,13 +30,14 @@ widget paymentIn = do R.divClass "payment" $ do rec _ <- Header.widget $ HeaderIn - { _headerIn_init = _paymentIn_init $ paymentIn + { _headerIn_init = init } _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn + { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pagesOut } pagesOut <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn + { _pagesIn_payments = _init_payments init } return $ PaymentOut {} + where init = _paymentIn_init paymentIn diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 67b4eb4..3f2adc3 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -4,22 +4,29 @@ module View.Payment.Header , HeaderOut(..) ) where -import qualified Data.List as L hiding (groupBy) -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L hiding (groupBy) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Time as Time +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Currency, Frequency (..), Init (..), - Payment (..), User (..), UserId) -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format +import Common.Model (Currency, ExceedingPayer (..), + Frequency (..), Income (..), Init (..), + Payment (..), 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 +import Component (ButtonIn (..)) +import qualified Component as Component +import qualified Util.List as L data HeaderIn t = HeaderIn - { _headerIn_init :: Init + { _headerIn_init :: Init } data HeaderOut = HeaderOut @@ -29,13 +36,37 @@ data HeaderOut = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut widget headerIn = R.divClass "header" $ do + payerAndAdd incomes payments users currency infos payments users currency return $ HeaderOut {} where init = _headerIn_init headerIn - payments = _init_payments init + incomes = _init_incomes init + payments = filter ((==) Punctual . _payment_frequency) (_init_payments init) users = _init_users init currency = _init_currency init +payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m () +payerAndAdd incomes payments users currency = do + time <- liftIO Time.getCurrentTime + R.divClass "payerAndAdd" $ do + R.divClass "exceedingPayers" $ + forM_ + (CM.getExceedingPayers time users incomes payments) + (\p -> + R.elClass "span" "exceedingPayer" $ do + R.elClass "span" "userName" $ + R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users + R.elClass "span" "amount" $ do + R.text "+ " + R.text . Format.price currency $ _exceedingPayer_amount p + ) + _ <- Component.button $ ButtonIn + { _buttonIn_class = R.constDyn "addPayment" + , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add + , _buttonIn_waiting = R.never + } + return () + infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m () infos payments users currency = R.divClass "infos" $ do @@ -52,14 +83,13 @@ infos payments users currency = T.intercalate ", " . map (\(userId, userTotal) -> Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users) + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) (Format.price currency userTotal) ) $ totalByUser - where punctualPayments = filter ((==) Punctual . _payment_frequency) payments - paymentCount = length punctualPayments - total = sum . map _payment_cost $ punctualPayments + where paymentCount = length payments + total = sum . map _payment_cost $ payments totalByUser :: [(UserId, Int)] totalByUser = @@ -67,4 +97,4 @@ infos payments users currency = . map (\(u, xs) -> (u, sum . map snd $ xs)) . L.groupBy fst . map (\p -> (_payment_user p, _payment_cost p)) - $ punctualPayments + $ payments diff --git a/common/common.cabal b/common/common.cabal index e4a9c59..7eadb49 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -47,6 +47,7 @@ Library Common.Model.Income Common.Model.Init Common.Model.InitResult + Common.Model.Payer Common.Model.Payment Common.Model.PaymentCategory Common.Model.SignIn diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 20e86c1..cb38b2f 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -12,6 +12,7 @@ import Common.Model.Frequency as X import Common.Model.Income as X import Common.Model.Init as X import Common.Model.InitResult as X +import Common.Model.Payer as X import Common.Model.Payment as X import Common.Model.PaymentCategory as X import Common.Model.SignIn as X diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs new file mode 100644 index 0000000..d09dbf6 --- /dev/null +++ b/common/src/Common/Model/Payer.hs @@ -0,0 +1,198 @@ +module Common.Model.Payer + ( getExceedingPayers + , ExceedingPayer(..) + ) where + +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Data.Time (NominalDiffTime, UTCTime (..)) +import qualified Data.Time as Time + +import Common.Model.Income (Income (..)) +import Common.Model.Payment (Payment (..)) +import Common.Model.User (User (..), UserId) + +data Payer = Payer + { _payer_userId :: UserId + , _payer_preIncomePayments :: Int + , _payer_postIncomePayments :: Int + , _payer_incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _postPaymentPayer_userId :: UserId + , _postPaymentPayer_preIncomePayments :: Int + , _postPaymentPayer_cumulativeIncome :: Int + , _postPaymentPayer_ratio :: Float + } + +data ExceedingPayer = ExceedingPayer + { _exceedingPayer_userId :: UserId + , _exceedingPayer_amount :: Int + } deriving (Show) + +getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer] +getExceedingPayers currentTime users incomes payments = + let userIds = map _user_id users + payers = getPayers currentTime userIds incomes payments + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers + mbSince = useIncomesFrom userIds incomes payments + in case mbSince of + Just since -> + let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: [UserId] -> [Income] -> [Payment] -> Maybe UTCTime +useIncomesFrom userIds incomes payments = + let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments + mbIncomeTime = incomeDefinedForAll userIds incomes + in case (firstPaymentTime, mbIncomeTime) of + (Just t1, Just t2) -> Just (max t1 t2) + _ -> Nothing + +paymentTime :: Payment -> UTCTime +paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date + +getPayers :: UTCTime -> [UserId] -> [Income] -> [Payment] -> [Payer] +getPayers currentTime userIds incomes payments = + let incomesDefined = incomeDefinedForAll userIds incomes + in flip map userIds (\userId -> Payer + { _payer_userId = userId + , _payer_preIncomePayments = + totalPayments + (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + userId + payments + , _payer_postIncomePayments = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> paymentTime p >= t + ) + userId + payments + , _payer_incomes = filter ((==) userId . _income_userId) incomes + } + ) + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> _exceedingPayer_amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _exceedingPayer_userId = fst userAmount + , _exceedingPayer_amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _postPaymentPayer_userId = _payer_userId payer + , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer + , _postPaymentPayer_cumulativeIncome = cumulativeIncome + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) + in postIncomeDiff + _postPaymentPayer_preIncomePayments payer + +incomeDefinedForAll :: [UserId] -> [Income] -> Maybe UTCTime +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds + firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + in if all Maybe.isJust firstIncomes + then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomeAt time incomes + orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: UTCTime -> [Income] -> Maybe Income +getIncomeAt time incomes = + case incomes of + [x] -> + if incomeTime x < time + then Just $ x { _income_date = utctDay time } + else Nothing + x1 : x2 : xs -> + if incomeTime x1 < time && incomeTime x2 >= time + then Just $ x1 { _income_date = utctDay time } + else getIncomeAt time (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs + +totalPayments :: (Payment -> Bool) -> UserId -> [Payment] -> Int +totalPayments paymentFilter userId payments = + sum + . map _payment_cost + . filter (\payment -> paymentFilter payment && _payment_user payment == userId) + $ payments diff --git a/server/server.cabal b/server/server.cabal index e4a1730..771a961 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -94,7 +94,6 @@ Executable server Model.Income Model.Init Model.Mail - Model.Payer Model.Payment Model.PaymentCategory Model.Query diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 792d482..904a2f5 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -57,7 +57,7 @@ design = do ".signOut" ? do Helper.waitable - heightMedia + display flex svg ? do Media.tabletDesktop $ width (px 30) Media.mobile $ width (px 20) diff --git a/server/src/Main.hs b/server/src/Main.hs index d7b9b93..c8080dc 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -8,6 +8,7 @@ import Network.Wai.Middleware.Static import Web.Scotty import Common.Model (Frequency (..), Payment (..)) +import qualified Common.Model as CM import qualified Conf import qualified Controller.Category as Category @@ -18,7 +19,6 @@ import qualified Controller.SignIn as SignIn import qualified Data.Time as Time import Job.Daemon (runDaemons) import qualified Model.Income as IncomeM -import Model.Payer (getOrderedExceedingPayers) import qualified Model.Payment as PaymentM import qualified Model.Query as Query import qualified Model.User as UserM @@ -36,7 +36,7 @@ main = do (users, incomes, payments) <- liftIO . Query.run $ liftA3 (,,) UserM.list IncomeM.list PaymentM.list let punctualPayments = filter ((==) Punctual . _payment_frequency) payments - exceedingPayers = getOrderedExceedingPayers time users incomes punctualPayments + exceedingPayers = CM.getExceedingPayers time users incomes punctualPayments text . LT.pack . show $ exceedingPayers get "/" $ do diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs deleted file mode 100644 index db3f37c..0000000 --- a/server/src/Model/Payer.hs +++ /dev/null @@ -1,217 +0,0 @@ -module Model.Payer - ( getOrderedExceedingPayers - ) where - -import qualified Data.List as List -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import Data.Time (NominalDiffTime, UTCTime (..)) -import qualified Data.Time as Time - -import Common.Model (Income (..), IncomeId, Payment (..), User (..), - UserId) - -type Users = Map UserId User - -type Payers = Map UserId Payer - -type Incomes = Map IncomeId Income - -type Payments = [Payment] - -data Payer = Payer - { preIncomePaymentSum :: Int - , postIncomePaymentSum :: Int - , _incomes :: [Income] - } - -data PostPaymentPayer = PostPaymentPayer - { _preIncomePaymentSum :: Int - , _cumulativeIncome :: Int - , ratio :: Float - } - -data ExceedingPayer = ExceedingPayer - { _userId :: UserId - , amount :: Int - } deriving (Show) - -getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] -getOrderedExceedingPayers currentTime users incomes payments = - let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users - incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes - payers = getPayers currentTime usersMap incomesMap payments - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts - . Map.toList - . Map.map preIncomePaymentSum - $ payers - mbSince = useIncomesFrom usersMap incomesMap payments - in case mbSince of - Just since -> - let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - safeMaximum - . map (ratio . snd) - . Map.toList - $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . Map.toList - . Map.map (getFinalDiff maxRatio) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime -useIncomesFrom users incomes payments = - let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments - mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just t1, Just t2) -> Just (max t1 t2) - _ -> Nothing - -paymentTime :: Payment -> UTCTime -paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date - -getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Map.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in Map.fromList - . map (\userId -> - ( userId - , Payer - { preIncomePaymentSum = - totalPayments - (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> paymentTime p >= t - ) - userId - payments - , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) - } - ) - ) - $ userIds - -exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] -exceedingPayersFromAmounts userAmounts = - case mbMinAmount of - Nothing -> - [] - Just minAmount -> - filter (\payer -> amount payer > 0) - . map (\userAmount -> - ExceedingPayer - { _userId = fst userAmount - , amount = snd userAmount - minAmount - } - ) - $ userAmounts - where mbMinAmount = safeMinimum . map snd $ userAmounts - -getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - PostPaymentPayer - { _preIncomePaymentSum = preIncomePaymentSum payer - , _cumulativeIncome = cumulativeIncome - , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) - } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) - -getFinalDiff :: Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) - in postIncomeDiff + _preIncomePaymentSum payer - -incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds - firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes - in if all Maybe.isJust firstIncomes - then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] -getOrderedIncomesSince time incomes = - let mbStarterIncome = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: UTCTime -> [Income] -> Maybe Income -getIncomeAt time incomes = - case incomes of - [x] -> - if incomeTime x < time - then Just $ x { _income_date = utctDay time } - else Nothing - x1 : x2 : xs -> - if incomeTime x1 < time && incomeTime x2 >= time - then Just $ x1 { _income_date = utctDay time } - else getIncomeAt time (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x : _) = Just x - -safeMinimum :: (Ord a) => [a] -> Maybe a -safeMinimum [] = Nothing -safeMinimum xs = Just . minimum $ xs - -safeMaximum :: (Ord a) => [a] -> Maybe a -safeMaximum [] = Nothing -safeMaximum xs = Just . maximum $ xs - -totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int -totalPayments paymentFilter userId payments = - sum - . map _payment_cost - . filter (\payment -> paymentFilter payment && _payment_user payment == userId) - $ payments -- cgit v1.2.3