From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Nov 2017 00:20:25 +0100
Subject: Show payment count and partition

- Also fixes exceedingPayer in back by using only punctual payments
---
 client/src/Component/Button.hs       |  2 --
 client/src/Component/Input.hs        |  2 --
 client/src/Icon.hs                   |  2 --
 client/src/Main.hs                   |  9 ++---
 client/src/Util/List.hs              | 13 +++++++
 client/src/View/App.hs               | 24 ++++++-------
 client/src/View/Header.hs            | 26 ++++++--------
 client/src/View/Payment.hs           | 22 ++++++------
 client/src/View/Payment/Constants.hs |  2 +-
 client/src/View/Payment/Header.hs    | 70 ++++++++++++++++++++++++++++++++++++
 client/src/View/Payment/Pages.hs     |  8 ++---
 client/src/View/Payment/Table.hs     | 28 +++++++--------
 client/src/View/SignIn.hs            | 32 ++++++++---------
 13 files changed, 152 insertions(+), 88 deletions(-)
 create mode 100644 client/src/Util/List.hs
 create mode 100644 client/src/View/Payment/Header.hs

(limited to 'client/src')

diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index c31cdc6..09c93cd 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Component.Button
   ( ButtonIn(..)
   , buttonInDefault
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index c3864b4..1923463 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Component.Input
   ( InputIn(..)
   , InputOut(..)
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
index cd5a0b4..fbf5388 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Icon
   ( clone
   , delete
diff --git a/client/src/Main.hs b/client/src/Main.hs
index cbc881c..d55eefe 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -13,9 +13,8 @@ import           JSDOM.Types                          (HTMLElement (..), JSM)
 import qualified JSDOM.Types                          as Dom
 import           Prelude                              hiding (error, init)
 
-import qualified Common.Message                       as Message
-import qualified Common.Message.Key                   as Key
 import           Common.Model                         (InitResult (InitEmpty))
+import qualified Common.Msg                           as Msg
 
 import qualified View.App                             as App
 
@@ -27,7 +26,8 @@ main = do
 readInit :: JSM InitResult
 readInit = do
   document <- Dom.currentDocumentUnchecked
-  initNode <- Dom.getElementById document "init"
+  initNode <- Dom.getElementById document ("init" :: Dom.JSString)
+
   case initNode of
     Just node -> do
       text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node)
@@ -36,4 +36,5 @@ readInit = do
         Nothing   -> initParseError
     _ ->
       return initParseError
-  where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError)
+
+  where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError)
diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs
new file mode 100644
index 0000000..4e22ba8
--- /dev/null
+++ b/client/src/Util/List.hs
@@ -0,0 +1,13 @@
+module Util.List
+  ( groupBy
+  ) where
+
+import           Control.Arrow ((&&&))
+import           Data.Function (on)
+import qualified Data.List     as L
+
+groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])]
+groupBy f =
+  map (f . head &&& id)
+    . L.groupBy ((==) `on` f)
+    . L.sortBy (compare `on` f)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 442fa3e..64ca303 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -1,22 +1,18 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.App
   ( widget
   ) where
 
-import           Prelude            hiding (error, init)
-import qualified Reflex.Dom         as R
+import           Prelude      hiding (error, init)
+import qualified Reflex.Dom   as R
 
-import qualified Common.Message     as Message
-import qualified Common.Message.Key as Key
-import           Common.Model       (InitResult (..))
+import           Common.Model (InitResult (..))
+import qualified Common.Msg   as Msg
 
-import           View.Header        (HeaderIn (..))
-import qualified View.Header        as Header
-import           View.Payment       (PaymentIn (..))
-import qualified View.Payment       as Payment
-import qualified View.SignIn        as SignIn
+import           View.Header  (HeaderIn (..))
+import qualified View.Header  as Header
+import           View.Payment (PaymentIn (..))
+import qualified View.Payment as Payment
+import qualified View.SignIn  as SignIn
 
 widget :: InitResult -> IO ()
 widget initResult =
@@ -36,7 +32,7 @@ widget initResult =
           InitEmpty result ->
             SignIn.view result
 
-        signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess)
+        signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess)
 
     _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
 
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 7afd9bd..4c74383 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -1,25 +1,21 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.Header
   ( view
   , HeaderIn(..)
   , HeaderOut(..)
   ) where
 
-import qualified Data.Map           as M
-import           Data.Time          (NominalDiffTime)
-import           Prelude            hiding (error, init)
-import           Reflex.Dom         (Event, MonadWidget)
-import qualified Reflex.Dom         as R
+import qualified Data.Map         as M
+import           Data.Time        (NominalDiffTime)
+import           Prelude          hiding (error, init)
+import           Reflex.Dom       (Event, MonadWidget)
+import qualified Reflex.Dom       as R
 
-import qualified Common.Message     as Message
-import qualified Common.Message.Key as Key
-import           Common.Model       (Init (..), InitResult (..), User (..))
-import qualified Common.Model       as CM
+import           Common.Model     (Init (..), InitResult (..), User (..))
+import qualified Common.Model     as CM
+import qualified Common.Msg       as Msg
 
-import           Component.Button   (ButtonIn (..))
-import qualified Component.Button   as Component
+import           Component.Button (ButtonIn (..))
+import qualified Component.Button as Component
 import qualified Icon
 
 data HeaderIn = HeaderIn
@@ -35,7 +31,7 @@ view headerIn =
   R.el "header" $ do
 
     R.divClass "title" $
-      R.text $ Message.get Key.App_Title
+      R.text $ Msg.get Msg.App_Title
 
     signOut <- nameSignOut $ _headerIn_initResult headerIn
 
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index f70c8cd..934f720 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -1,21 +1,20 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.Payment
   ( widget
   , PaymentIn(..)
   , PaymentOut(..)
   ) where
 
-import           Reflex.Dom         (MonadWidget)
-import qualified Reflex.Dom         as R
+import           Reflex.Dom          (MonadWidget)
+import qualified Reflex.Dom          as R
 
-import           Common.Model       (Init (..))
+import           Common.Model        (Init (..))
 
-import           View.Payment.Pages (PagesIn (..), PagesOut (..))
-import qualified View.Payment.Pages as Pages
-import           View.Payment.Table (TableIn (..))
-import qualified View.Payment.Table as Table
+import           View.Payment.Header (HeaderIn (..))
+import qualified View.Payment.Header as Header
+import           View.Payment.Pages  (PagesIn (..), PagesOut (..))
+import qualified View.Payment.Pages  as Pages
+import           View.Payment.Table  (TableIn (..))
+import qualified View.Payment.Table  as Table
 
 data PaymentIn = PaymentIn
   { _paymentIn_init :: Init
@@ -29,6 +28,9 @@ widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut
 widget paymentIn = do
   R.divClass "payment" $ do
     rec
+      _ <- Header.widget $ HeaderIn
+        { _headerIn_init = _paymentIn_init $ paymentIn
+        }
       _ <- Table.widget $ TableIn
         { _tableIn_init = _paymentIn_init paymentIn
         , _tableIn_currentPage = _pagesOut_currentPage pagesOut
diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs
index ac2320a..028e328 100644
--- a/client/src/View/Payment/Constants.hs
+++ b/client/src/View/Payment/Constants.hs
@@ -3,4 +3,4 @@ module View.Payment.Constants
   ) where
 
 paymentsPerPage :: Int
-paymentsPerPage = 8
+paymentsPerPage = 7
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
new file mode 100644
index 0000000..67b4eb4
--- /dev/null
+++ b/client/src/View/Payment/Header.hs
@@ -0,0 +1,70 @@
+module View.Payment.Header
+  ( widget
+  , HeaderIn(..)
+  , 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           Common.Model       (Currency, Frequency (..), Init (..),
+                                     Payment (..), User (..), UserId)
+import qualified Common.Msg         as Msg
+import qualified Common.View.Format as Format
+
+import qualified Util.List          as L
+
+data HeaderIn t = HeaderIn
+  { _headerIn_init    :: Init
+  }
+
+data HeaderOut = HeaderOut
+  {
+  }
+
+widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut
+widget headerIn =
+  R.divClass "header" $ do
+    infos payments users currency
+    return $ HeaderOut {}
+  where init = _headerIn_init headerIn
+        payments = _init_payments init
+        users = _init_users init
+        currency = _init_currency init
+
+infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m ()
+infos payments users currency =
+  R.divClass "infos" $ 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 total)
+    R.elClass "span" "partition" . R.text $
+      T.intercalate ", "
+        . map (\(userId, userTotal) ->
+            Msg.get $ Msg.Payment_By
+              (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users)
+              (Format.price currency userTotal)
+          )
+        $ totalByUser
+
+  where punctualPayments = filter ((==) Punctual . _payment_frequency) payments
+        paymentCount = length punctualPayments
+        total = sum . map _payment_cost $ punctualPayments
+
+        totalByUser :: [(UserId, Int)]
+        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))
+            $ punctualPayments
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index f96cb8e..81555ab 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.Payment.Pages
   ( widget
   , PagesIn(..)
@@ -11,7 +8,7 @@ import qualified Data.Text              as T
 import           Reflex.Dom             (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Payment (..))
+import           Common.Model           (Frequency (..), Payment (..))
 
 import           Component              (ButtonIn (..), ButtonOut (..))
 import qualified Component              as Component
@@ -48,7 +45,8 @@ widget pagesIn = do
       { _pagesOut_currentPage = currentPage
       }
 
-    where maxPage = ceiling $ (toRational . length . _pagesIn_payments $ pagesIn) / toRational Constants.paymentsPerPage
+    where paymentCount = length . filter ((==) Punctual . _payment_frequency) . _pagesIn_payments $ pagesIn
+          maxPage = ceiling $ toRational paymentCount / toRational Constants.paymentsPerPage
           pageEvent = R.switchPromptlyDyn . fmap R.leftmost
 
 range :: Int -> Int -> [Int]
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 5c0b709..d8093a5 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.Payment.Table
   ( widget
   , TableIn(..)
@@ -15,11 +12,11 @@ import           Prelude                hiding (init)
 import           Reflex.Dom             (Dynamic, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import qualified Common.Message         as Message
-import qualified Common.Message.Key     as Key
-import           Common.Model           (Category (..), Init (..), Payment (..),
+import           Common.Model           (Category (..), Frequency (..),
+                                         Init (..), Payment (..),
                                          PaymentCategory (..), User (..))
 import qualified Common.Model           as CM
+import qualified Common.Msg             as Msg
 import qualified Common.Util.Text       as T
 import qualified Common.View.Format     as Format
 
@@ -40,11 +37,11 @@ widget tableIn = do
   _ <- R.divClass "table" $
     R.divClass "lines" $ do
       R.divClass "header" $ do
-        R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name
-        R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost
-        R.divClass "cell user" $ R.text $ Message.get Key.Payment_User
-        R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category
-        R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date
+        R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
+        R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost
+        R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User
+        R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category
+        R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
@@ -58,10 +55,11 @@ widget tableIn = do
 getPaymentRange :: [Payment] -> Int -> [Payment]
 getPaymentRange payments currentPage =
   take Constants.paymentsPerPage
-  . drop ((currentPage - 1) * Constants.paymentsPerPage)
-  . reverse
-  . L.sortOn _payment_date
-  $ payments
+    . drop ((currentPage - 1) * Constants.paymentsPerPage)
+    . reverse
+    . L.sortOn _payment_date
+    . filter ((==) Punctual . _payment_frequency)
+    $ payments
 
 paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m ()
 paymentRow init payment =
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 1f5b900..69596d8 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -1,25 +1,21 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.SignIn
   ( view
   ) where
 
-import qualified Data.Either        as Either
-import           Data.Monoid        ((<>))
-import           Data.Text          (Text)
-import           Data.Time          (NominalDiffTime)
-import           Prelude            hiding (error)
-import           Reflex.Dom         (Event, MonadWidget)
-import qualified Reflex.Dom         as R
+import qualified Data.Either  as Either
+import           Data.Monoid  ((<>))
+import           Data.Text    (Text)
+import           Data.Time    (NominalDiffTime)
+import           Prelude      hiding (error)
+import           Reflex.Dom   (Event, MonadWidget)
+import qualified Reflex.Dom   as R
 
-import qualified Common.Message     as Message
-import qualified Common.Message.Key as Key
-import           Common.Model       (SignIn (SignIn))
+import           Common.Model (SignIn (SignIn))
+import qualified Common.Msg   as Msg
 
-import           Component          (ButtonIn (..), ButtonOut (..),
-                                     InputIn (..), InputOut (..))
-import qualified Component          as Component
+import           Component    (ButtonIn (..), ButtonOut (..), InputIn (..),
+                               InputOut (..))
+import qualified Component    as Component
 
 view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m ()
 view result =
@@ -27,7 +23,7 @@ view result =
     rec
       input <- Component.input $ InputIn
         { _inputIn_reset = R.ffilter Either.isRight signInResult
-        , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder
+        , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder
         }
 
       let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
@@ -50,7 +46,7 @@ view result =
 
       button <- Component.button $ ButtonIn
         { _buttonIn_class = R.constDyn ""
-        , _buttonIn_content = R.text (Message.get Key.SignIn_Button)
+        , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button)
         , _buttonIn_waiting = waiting
         }
 
-- 
cgit v1.2.3