Add exceeding payer block

4 files changed, 55 insertions, 29 deletions

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