Show payment header infos

5 files changed, 204 insertions, 223 deletions

diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
deleted file mode 100644
index c8ca347..0000000
--- a/client/src/View/Payment/Header.hs
+++ /dev/null
@@ -1,187 +0,0 @@
-module View.Payment.Header
-  ( view
-  , In(..)
-  , Out(..)
-  ) where
-
-import           Control.Monad          (forM_)
-import           Control.Monad.IO.Class (liftIO)
-import qualified Data.List              as L hiding (groupBy)
-import qualified Data.Map               as M
-import           Data.Maybe             (fromMaybe)
-import           Data.Text              (Text)
-import qualified Data.Text              as T
-import           Data.Time              (NominalDiffTime)
-import qualified Data.Time              as Time
-import qualified Data.Validation        as V
-import           Prelude                hiding (init)
-import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex)
-import qualified Reflex.Dom             as R
-
-import           Common.Model           (Category, Currency,
-                                         ExceedingPayer (..), Frequency (..),
-                                         Income (..), Payment (..),
-                                         PaymentCategory, SavedPayment (..),
-                                         User (..))
-import qualified Common.Model           as CM
-import qualified Common.Msg             as Msg
-import qualified Common.View.Format     as Format
-
-import qualified Component.Button       as Button
-import qualified Component.Input        as Input
-import qualified Component.Modal        as Modal
-import qualified Component.Select       as Select
-import qualified Util.List              as L
-import qualified View.Payment.Form      as Form
-import           View.Payment.Init      (Init (..))
-
-data In t = In
-  { _in_init              :: Init
-  , _in_currency          :: Currency
-  , _in_payments          :: Dynamic t [Payment]
-  , _in_searchPayments    :: Dynamic t [Payment]
-  , _in_paymentCategories :: Dynamic t [PaymentCategory]
-  }
-
-data Out t = Out
-  { _out_searchName      :: Dynamic t Text
-  , _out_searchFrequency :: Dynamic t Frequency
-  , _out_addPayment      :: Event t SavedPayment
-  }
-
-view :: forall t m. MonadWidget t m => In t -> m (Out t)
-view input =
-  R.divClass "header" $ do
-    rec
-      addPayment <-
-        payerAndAdd
-          incomes
-          payments
-          users
-          categories
-          paymentCategories
-          currency
-          searchFrequency
-      let resetSearchName = fmap (const ()) $ addPayment
-      (searchName, searchFrequency)  <- searchLine resetSearchName
-
-      infos (_in_searchPayments input) users currency
-
-    return $ Out
-      { _out_searchName = searchName
-      , _out_searchFrequency = searchFrequency
-      , _out_addPayment = addPayment
-      }
-  where
-    init = _in_init input
-    incomes = _init_incomes init
-    initPayments = _init_payments init
-    payments = _in_payments input
-    users = _init_users init
-    categories = _init_categories init
-    currency = _in_currency input
-    paymentCategories = _in_paymentCategories input
-
-payerAndAdd
-  :: forall t m. MonadWidget t m
-  => [Income]
-  -> Dynamic t [Payment]
-  -> [User]
-  -> [Category]
-  -> Dynamic t [PaymentCategory]
-  -> Currency
-  -> Dynamic t Frequency
-  -> m (Event t SavedPayment)
-payerAndAdd incomes payments users categories paymentCategories currency frequency = do
-  time <- liftIO Time.getCurrentTime
-  R.divClass "payerAndAdd" $ do
-
-    let exceedingPayers =
-          R.ffor payments $ \ps ->
-            CM.getExceedingPayers time users incomes $
-              filter ((==) Punctual . _payment_frequency) ps
-
-    R.divClass "exceedingPayers" $
-      R.simpleList exceedingPayers $ \exceedingPayer ->
-        R.elClass "span" "exceedingPayer" $ do
-          R.elClass "span" "userName" $
-            R.dynText . R.ffor exceedingPayer $ \ep ->
-              fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users
-          R.elClass "span" "amount" $ do
-            R.text "+ "
-            R.dynText . R.ffor exceedingPayer $ \ep ->
-              Format.price currency $ _exceedingPayer_amount ep
-
-    addPayment <- Button._out_clic <$>
-      (Button.view $
-        (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add))
-          { Button._in_class = R.constDyn "addPayment"
-          })
-
-    Modal.view $ Modal.In
-      { Modal._in_show    = addPayment
-      , Modal._in_content = \_ -> return (R.never, R.never) -- TODO
-      }
-
-searchLine
-  :: forall t m. MonadWidget t m
-  => Event t ()
-  -> m (Dynamic t Text, Dynamic t Frequency)
-searchLine reset = do
-  R.divClass "searchLine" $ do
-    searchName <- Input._out_raw <$> (Input.view
-      ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
-      ("" <$ reset)
-      R.never)
-
-    let frequencies = M.fromList
-          [ (Punctual, Msg.get Msg.Payment_PunctualMale)
-          , (Monthly, Msg.get Msg.Payment_MonthlyMale)
-          ]
-
-    searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
-        { Select._in_label        = ""
-        , Select._in_initialValue = Punctual
-        , Select._in_value        = R.never
-        , Select._in_values       = R.constDyn frequencies
-        , Select._in_reset        = R.never
-        , Select._in_isValid      = V.Success
-        , Select._in_validate     = R.never
-        })
-
-    return (searchName, searchFrequency)
-
-infos
-  :: forall t m. MonadWidget t m
-  => Dynamic t [Payment]
-  -> [User]
-  -> Currency -> m ()
-infos payments users currency =
-  R.divClass "infos" $ do
-
-    R.elClass "span" "total" $ do
-      R.dynText $ do
-        ps <- payments
-        let paymentCount = length ps
-            total = sum . map _payment_cost $ ps
-        pure . 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.dynText $ do
-      ps <- payments
-      let 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))
-              $ ps
-      pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) ->
-        Msg.get $ Msg.Payment_By
-          (fromMaybe "" . fmap _user_name $ CM.findUser userId users)
-          (Format.price currency userTotal)
diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs
new file mode 100644
index 0000000..07a6b81
--- /dev/null
+++ b/client/src/View/Payment/HeaderForm.hs
@@ -0,0 +1,78 @@
+module View.Payment.HeaderForm
+  ( view
+  ) where
+
+import qualified Data.Map          as M
+import           Data.Text         (Text)
+import qualified Data.Validation   as V
+import           Reflex.Dom        (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom        as R
+
+import           Common.Model      (Category, Currency, ExceedingPayer (..),
+                                    Frequency (..), Income (..), Payment (..),
+                                    PaymentCategory, SavedPayment (..),
+                                    User (..))
+import qualified Common.Msg        as Msg
+
+import qualified Component.Button  as Button
+import qualified Component.Input   as Input
+import qualified Component.Modal   as Modal
+import qualified Component.Select  as Select
+import qualified View.Payment.Form as Form
+
+data In t = In
+  { _in_reset             :: Event t ()
+  , _in_categories        :: [Category]
+  , _in_paymentCategories :: [PaymentCategory]
+  }
+
+data Out = Out
+  { _out_name       :: Event t Text
+  , _out_frequency  :: Event t Frequency
+  , _out_addPayment :: Event t SavedPayment
+  }
+
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input = do
+  R.divClass "g-HeaderForm" $ do
+    searchName <- Input._out_raw <$> (Input.view
+      ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
+      ("" <$ _in_reset input)
+      R.never)
+
+    let frequencies = M.fromList
+          [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+          , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+          ]
+
+    searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
+        { Select._in_label        = ""
+        , Select._in_initialValue = Punctual
+        , Select._in_value        = R.never
+        , Select._in_values       = R.constDyn frequencies
+        , Select._in_reset        = R.never
+        , Select._in_isValid      = V.Success
+        , Select._in_validate     = R.never
+        })
+
+    addPaymentButton <- Button._out_clic <$>
+      (Button.view $
+        (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add))
+          { Button._in_class = R.constDyn "addPayment"
+          })
+
+    addPayment <- Modal.view $ Modal.In
+      { Modal._in_show    = addPaymentButton
+      , Modal._in_content =
+        Form.view $ Form.In
+          { Form._in_categories = _in_categories input
+          , Form._in_paymentCategories = _in_paymentCategories input
+          , Form._in_operation = Form.New searchFrequency
+          }
+      }
+
+    return $ Out
+      { _out_name = searchName
+      , _out_frequency = searchFrequency
+      , _out_addPayment = addPayment
+      }
diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs
new file mode 100644
index 0000000..12facc4
--- /dev/null
+++ b/client/src/View/Payment/HeaderInfos.hs
@@ -0,0 +1,96 @@
+module View.Payment.HeaderInfos
+  ( view
+  , In(..)
+  ) where
+
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.List              as L hiding (groupBy)
+import           Data.Map               (Map)
+import qualified Data.Map               as M
+import           Data.Maybe             (fromMaybe)
+import           Data.Text              (Text)
+import qualified Data.Text              as T
+import qualified Data.Time              as Time
+import           Reflex.Dom             (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom             as R
+
+import           Common.Model           (Currency, ExceedingPayer (..),
+                                         Payment (..), PaymentHeader (..),
+                                         SavedPayment (..), 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
+
+data In t = In
+  { _in_users        :: [User]
+  , _in_currency     :: Currency
+  , _in_header       :: PaymentHeader
+  , _in_paymentCount :: Int
+  }
+
+view :: forall t m. MonadWidget t m => In t -> m ()
+view input =
+  R.divClass "g-HeaderInfos" $ do
+      exceedingPayers
+        (_in_users input)
+        (_in_currency input)
+        (_paymentHeader_exceedingPayers header)
+
+      infos
+        (_in_users input)
+        (_in_currency input)
+        (_paymentHeader_repartition header)
+        (_in_paymentCount input)
+
+  where
+    header = _in_header input
+
+exceedingPayers
+  :: forall t m. MonadWidget t m
+  => [User]
+  -> Currency
+  -> [ExceedingPayer]
+  -> m ()
+exceedingPayers users currency payers =
+  R.divClass "g-HeaderInfos__ExceedingPayers" $
+    flip mapM_ payers $ \payer ->
+      R.elClass "span" "exceedingPayer" $ do
+        R.elClass "span" "userName" $
+          R.text $
+            fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId payer) users
+        R.elClass "span" "amount" $ do
+          R.text "+ "
+          R.text . Format.price currency $ _exceedingPayer_amount payer
+
+infos
+  :: forall t m. MonadWidget t m
+  => [User]
+  -> Currency
+  -> Map UserId Int
+  -> Int
+  -> m ()
+infos users currency repartition paymentCount =
+  R.divClass "g-HeaderInfos__Repartition" $ 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 (M.foldl (+) 0 repartition))
+
+    R.elClass "span" "partition" . R.text $
+      let totalByUser =
+            L.sortBy (\(_, t1) (_, t2) -> compare t2 t1)
+              . M.toList
+              $ repartition
+      in  T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) ->
+            Msg.get $ Msg.Payment_By
+              (fromMaybe "" . fmap _user_name $ CM.findUser userId users)
+              (Format.price currency userTotal)
diff --git a/client/src/View/Payment/Init.hs b/client/src/View/Payment/Init.hs
deleted file mode 100644
index d9f85c8..0000000
--- a/client/src/View/Payment/Init.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module View.Payment.Init
-  ( Init(..)
-  ) where
-
-import           Common.Model (Category, Income, Payment, PaymentCategory, User)
-
-data Init = Init
-  { _init_users             :: [User]
-  , _init_payments          :: [Payment]
-  , _init_incomes           :: [Income]
-  , _init_categories        :: [Category]
-  , _init_paymentCategories :: [PaymentCategory]
-  } deriving (Show)
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index bf0186f..f47b627 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -3,29 +3,29 @@ module View.Payment.Payment
   , In(..)
   ) where
 
-import qualified Data.Maybe           as Maybe
-import           Data.Text            (Text)
-import qualified Data.Text            as T
-import           Data.Time.Clock      (NominalDiffTime)
-import           Prelude              hiding (init)
-import           Reflex.Dom           (Dynamic, Event, MonadWidget, Reflex)
-import qualified Reflex.Dom           as R
-
-import           Common.Model         (Currency, Frequency, Income (..),
-                                       Payment (..), PaymentCategory (..),
-                                       PaymentId, PaymentPage (..),
-                                       SavedPayment (..), User, UserId)
-import qualified Common.Util.Text     as T
-
-import qualified Component.Pages      as Pages
-import           Loadable             (Loadable (..))
+import qualified Data.Maybe               as Maybe
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import           Data.Time.Clock          (NominalDiffTime)
+import           Prelude                  hiding (init)
+import           Reflex.Dom               (Dynamic, Event, MonadWidget, Reflex)
+import qualified Reflex.Dom               as R
+
+import           Common.Model             (Currency, Frequency, Income (..),
+                                           Payment (..), PaymentCategory (..),
+                                           PaymentId, PaymentPage (..),
+                                           SavedPayment (..), User, UserId)
+import qualified Common.Util.Text         as T
+
+import qualified Component.Pages          as Pages
+import           Loadable                 (Loadable (..))
 import qualified Loadable
-import qualified Util.Ajax            as AjaxUtil
-import qualified Util.Reflex          as ReflexUtil
-import qualified View.Payment.Header  as Header
-import           View.Payment.Init    (Init (..))
-import qualified View.Payment.Reducer as Reducer
-import qualified View.Payment.Table   as Table
+import qualified Util.Ajax                as AjaxUtil
+import qualified Util.Reflex              as ReflexUtil
+import qualified View.Payment.HeaderInfos as HeaderInfos
+-- import qualified View.Payment.HeaderForm as HeaderForm
+import qualified View.Payment.Reducer     as Reducer
+import qualified View.Payment.Table       as Table
 
 data In t = In
   { _in_currentUser :: UserId
@@ -61,7 +61,14 @@ view input = do
       deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
 
       result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) ->
-        flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do
+        flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do
+          HeaderInfos.view $ HeaderInfos.In
+            { HeaderInfos._in_users = _in_users input
+            , HeaderInfos._in_currency = _in_currency input
+            , HeaderInfos._in_header = header
+            , HeaderInfos._in_paymentCount = count
+            }
+
           table <- Table.view $ Table.In
             { Table._in_users = _in_users input
             , Table._in_currentUser = _in_currentUser input