Add exceeding payer block

2 files changed, 53 insertions, 21 deletions

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