From 04c59f08f100ba6a0658d1f2b357f7d8b1e14218 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 13 Oct 2019 22:38:35 +0200
Subject: Show income table

---
 ISSUES.md                                |   4 +-
 client/client.cabal                      |   4 +-
 client/src/Component.hs                  |   1 +
 client/src/Component/Table.hs            |  38 ++++++++
 client/src/View/App.hs                   |  40 ++++----
 client/src/View/Income/Income.hs         |  68 ++++++++++++++
 client/src/View/Payment.hs               | 154 -------------------------------
 client/src/View/Payment/Payment.hs       | 154 +++++++++++++++++++++++++++++++
 client/src/View/Payment/Table.hs         |   3 -
 common/src/Common/Message/Key.hs         |   1 +
 common/src/Common/Message/Translation.hs |   9 +-
 11 files changed, 297 insertions(+), 179 deletions(-)
 create mode 100644 client/src/Component/Table.hs
 create mode 100644 client/src/View/Income/Income.hs
 delete mode 100644 client/src/View/Payment.hs
 create mode 100644 client/src/View/Payment/Payment.hs

diff --git a/ISSUES.md b/ISSUES.md
index 92e9052..fbbcc87 100644
--- a/ISSUES.md
+++ b/ISSUES.md
@@ -1,7 +1,8 @@
 ## Income view
 
-- Show the income table
+- Show the income header
 - Add an income
+- Clone an income
 - Edit an income
 - Remove an income
 
@@ -9,6 +10,7 @@
 
 - Show the category table
 - Add a category
+- Clone a category
 - Edit a category
 - Remove a category
 
diff --git a/client/client.cabal b/client/client.cabal
index 55ba5e1..f8fe1e1 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -50,6 +50,7 @@ Executable client
     Component.Input
     Component.Link
     Component.Modal
+    Component.Table
     Component.Select
     Icon
     Util.Ajax
@@ -62,8 +63,8 @@ Executable client
     Util.WaitFor
     View.App
     View.Header
+    View.Income.Income
     View.NotFound
-    View.Payment
     View.Payment.Add
     View.Payment.Clone
     View.Payment.Delete
@@ -71,5 +72,6 @@ Executable client
     View.Payment.Form
     View.Payment.Header
     View.Payment.Pages
+    View.Payment.Payment
     View.Payment.Table
     View.SignIn
diff --git a/client/src/Component.hs b/client/src/Component.hs
index 7e0b151..97c250e 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -6,3 +6,4 @@ import           Component.Input  as X
 import           Component.Link   as X
 import           Component.Modal  as X
 import           Component.Select as X
+import           Component.Table  as X
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
new file mode 100644
index 0000000..a77a18d
--- /dev/null
+++ b/client/src/Component/Table.hs
@@ -0,0 +1,38 @@
+module Component.Table
+  ( table
+  , TableIn(..)
+  , TableOut(..)
+  ) where
+
+import           Data.Text  (Text)
+import           Reflex.Dom (Dynamic, MonadWidget)
+import qualified Reflex.Dom as R
+
+data TableIn h r t = TableIn
+  { _tableIn_headerLabel :: h -> Text
+  , _tableIn_rows        :: Dynamic t [r]
+  , _tableIn_cell        :: h -> r -> Text
+  }
+
+data TableOut = TableOut
+  {}
+
+table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h)  => TableIn h r t -> m (TableOut)
+table tableIn = do
+  R.divClass "table" $ do
+
+    R.divClass "lines" $ do
+      R.divClass "header" $ do
+        flip mapM_ [minBound..] $ \header ->
+          R.divClass "cell" . R.text $
+            _tableIn_headerLabel tableIn header
+
+      R.simpleList (_tableIn_rows tableIn) $ \r ->
+        R.divClass "row" $
+          flip mapM_ [minBound..] $ \h ->
+            R.divClass "cell name" $
+              R.dynText $
+                R.ffor r (_tableIn_cell tableIn h)
+
+    return $ TableOut
+      {}
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index d853c7e..3292336 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -2,22 +2,24 @@ module View.App
   ( widget
   ) where
 
-import qualified Data.Text     as T
-import           Prelude       hiding (error, init)
-import           Reflex.Dom    (Dynamic, MonadWidget)
-import qualified Reflex.Dom    as R
-
-import           Common.Model  (Init, InitResult (..))
-import qualified Common.Msg    as Msg
-
-import           Model.Route   (Route (..))
-import qualified Util.Router   as Router
-import           View.Header   (HeaderIn (..))
-import qualified View.Header   as Header
-import qualified View.NotFound as NotFound
-import           View.Payment  (PaymentIn (..))
-import qualified View.Payment  as Payment
-import qualified View.SignIn   as SignIn
+import qualified Data.Text            as T
+import           Prelude              hiding (error, init)
+import           Reflex.Dom           (Dynamic, MonadWidget)
+import qualified Reflex.Dom           as R
+
+import           Common.Model         (Init, InitResult (..))
+import qualified Common.Msg           as Msg
+
+import           Model.Route          (Route (..))
+import qualified Util.Router          as Router
+import           View.Header          (HeaderIn (..))
+import qualified View.Header          as Header
+import           View.Income.Income   (IncomeIn (..))
+import qualified View.Income.Income   as Income
+import qualified View.NotFound        as NotFound
+import           View.Payment.Payment (PaymentIn (..))
+import qualified View.Payment.Payment as Payment
+import qualified View.SignIn          as SignIn
 
 widget :: InitResult -> IO ()
 widget initResult =
@@ -59,12 +61,14 @@ signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
 signedWidget init route = do
   R.dyn . R.ffor route $ \case
     RootRoute ->
-      Payment.widget $ PaymentIn
+      Payment.view $ PaymentIn
         { _paymentIn_init = init
         }
 
     IncomeRoute ->
-      R.el "div" $ R.text "Incomes"
+      Income.view $ IncomeIn
+        { _incomeIn_init = init
+        }
 
     NotFoundRoute ->
       NotFound.view
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
new file mode 100644
index 0000000..5e9ce1d
--- /dev/null
+++ b/client/src/View/Income/Income.hs
@@ -0,0 +1,68 @@
+module View.Income.Income
+  ( view
+  , IncomeIn(..)
+  ) where
+
+import qualified Data.List          as L
+import qualified Data.Maybe         as Maybe
+import           Data.Text          (Text)
+import qualified Data.Text          as T
+import           Reflex.Dom         (MonadWidget)
+import qualified Reflex.Dom         as R
+
+import           Common.Model       (Income (..), Init (..), User (..))
+import qualified Common.Model       as CM
+import qualified Common.Msg         as Msg
+import qualified Common.View.Format as Format
+import           Component          (TableIn (..))
+import qualified Component
+
+data IncomeIn = IncomeIn
+  { _incomeIn_init :: Init
+  }
+
+view :: forall t m. MonadWidget t m => IncomeIn -> m ()
+view incomeIn =
+  R.elClass "main" "income" $ do
+
+    R.divClass "withMargin" $
+      R.divClass "titleButton" $
+        R.el "h1" $
+          R.text $
+            Msg.get Msg.Income_MonthlyNet
+
+    Component.table $ TableIn
+      { _tableIn_headerLabel = headerLabel
+      , _tableIn_rows =
+        R.constDyn
+        . reverse
+        . L.sortOn _income_date
+        . _init_incomes
+        . _incomeIn_init
+        $ incomeIn
+      , _tableIn_cell = cell (_incomeIn_init incomeIn)
+      }
+    return ()
+
+data Header
+  = UserHeader
+  | AmountHeader
+  | DateHeader
+  deriving (Eq, Show, Bounded, Enum)
+
+headerLabel :: Header -> Text
+headerLabel UserHeader   = Msg.get Msg.Income_Name
+headerLabel DateHeader   = Msg.get Msg.Income_Date
+headerLabel AmountHeader = Msg.get Msg.Income_Amount
+
+cell :: Init -> Header -> Income -> Text
+cell init header income =
+  case header of
+    UserHeader ->
+      Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init)
+
+    DateHeader ->
+      Format.longDay . _income_date $ income
+
+    AmountHeader ->
+      Format.price (_init_currency init) . _income_amount $ income
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
deleted file mode 100644
index 1072a5e..0000000
--- a/client/src/View/Payment.hs
+++ /dev/null
@@ -1,154 +0,0 @@
-module View.Payment
-  ( widget
-  , PaymentIn(..)
-  ) where
-
-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        (Frequency, Init (..), Payment (..),
-                                      PaymentCategory (..), PaymentId,
-                                      SavedPayment (..))
-import qualified Common.Util.Text    as T
-import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
-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 (..), TableOut (..))
-import qualified View.Payment.Table  as Table
-
-data PaymentIn = PaymentIn
-  { _paymentIn_init :: Init
-  }
-
-widget :: forall t m. MonadWidget t m => PaymentIn -> m ()
-widget paymentIn = do
-  R.elClass "main" "payment" $ do
-    rec
-      let init = _paymentIn_init paymentIn
-
-          paymentsPerPage = 7
-
-          addPayment = R.leftmost
-            [ _headerOut_addPayment header
-            , _tableOut_addPayment table
-            ]
-
-      payments <- reducePayments
-        (_init_payments init)
-        (_savedPayment_payment <$> addPayment)
-        (_savedPayment_payment <$> _tableOut_editPayment table)
-        (_tableOut_deletePayment table)
-
-      paymentCategories <- reducePaymentCategories
-        (_init_paymentCategories init)
-        payments
-        (_savedPayment_paymentCategory <$> addPayment)
-        (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
-        (_tableOut_deletePayment table)
-
-      (searchNameEvent, searchName) <-
-        debounceSearchName (_headerOut_searchName header)
-
-      let searchPayments =
-            getSearchPayments searchName (_headerOut_searchFrequency header) payments
-
-      header <- Header.widget $ HeaderIn
-        { _headerIn_init = init
-        , _headerIn_payments = payments
-        , _headerIn_searchPayments = searchPayments
-        , _headerIn_paymentCategories = paymentCategories
-        }
-
-      table <- Table.widget $ TableIn
-        { _tableIn_init = init
-        , _tableIn_currentPage = _pagesOut_currentPage pages
-        , _tableIn_payments = searchPayments
-        , _tableIn_perPage = paymentsPerPage
-        , _tableIn_paymentCategories = paymentCategories
-        }
-
-      pages <- Pages.widget $ PagesIn
-        { _pagesIn_total = length <$> searchPayments
-        , _pagesIn_perPage = paymentsPerPage
-        , _pagesIn_reset = R.leftmost $
-            [ () <$ searchNameEvent
-            , () <$ _headerOut_addPayment header
-            ]
-        }
-
-    pure ()
-
-debounceSearchName
-  :: forall t m. MonadWidget t m
-  => Dynamic t Text
-  -> m (Event t Text, Dynamic t Text)
-debounceSearchName searchName = do
-  event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName)
-  dynamic <- R.holdDyn "" event
-  return (event, dynamic)
-
-reducePayments
-  :: forall t m. MonadWidget t m
-  => [Payment]
-  -> Event t Payment -- add payment
-  -> Event t Payment -- edit payment
-  -> Event t Payment -- delete payment
-  -> m (Dynamic t [Payment])
-reducePayments initPayments addPayment editPayment deletePayment =
-  R.foldDyn id initPayments $ R.leftmost
-    [ (:) <$> addPayment
-    , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id))
-    , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
-    ]
-
-reducePaymentCategories
-  :: forall t m. MonadWidget t m
-  => [PaymentCategory]
-  -> Dynamic t [Payment]      -- payments
-  -> Event t PaymentCategory  -- add payment category
-  -> Event t PaymentCategory  -- edit payment category
-  -> Event t Payment          -- delete payment
-  -> m (Dynamic t [PaymentCategory])
-reducePaymentCategories
-  initPaymentCategories
-  payments
-  addPaymentCategory
-  editPaymentCategory
-  deletePayment
-    =
-  R.foldDyn id initPaymentCategories $ R.leftmost
-    [ (:) <$> addPaymentCategory
-    , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name))
-    , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
-    ]
-  where
-    deletePaymentName =
-      R.attachWithMaybe
-        (\ps p ->
-          if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then
-            Nothing
-          else
-            Just (_payment_name p))
-        (R.current payments)
-        deletePayment
-    lowerName = T.toLower . _payment_name
-
-getSearchPayments
-  :: forall t. Reflex t
-  => Dynamic t Text
-  -> Dynamic t Frequency
-  -> Dynamic t [Payment]
-  -> Dynamic t [Payment]
-getSearchPayments name frequency payments = do
-  n <- name
-  f <- frequency
-  ps <- payments
-  pure $ flip filter ps (\p ->
-    (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
-    && (_payment_frequency p == f)
-    ))
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
new file mode 100644
index 0000000..cfdb441
--- /dev/null
+++ b/client/src/View/Payment/Payment.hs
@@ -0,0 +1,154 @@
+module View.Payment.Payment
+  ( view
+  , PaymentIn(..)
+  ) where
+
+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        (Frequency, Init (..), Payment (..),
+                                      PaymentCategory (..), PaymentId,
+                                      SavedPayment (..))
+import qualified Common.Util.Text    as T
+import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
+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 (..), TableOut (..))
+import qualified View.Payment.Table  as Table
+
+data PaymentIn = PaymentIn
+  { _paymentIn_init :: Init
+  }
+
+view :: forall t m. MonadWidget t m => PaymentIn -> m ()
+view paymentIn = do
+  R.elClass "main" "payment" $ do
+    rec
+      let init = _paymentIn_init paymentIn
+
+          paymentsPerPage = 7
+
+          addPayment = R.leftmost
+            [ _headerOut_addPayment header
+            , _tableOut_addPayment table
+            ]
+
+      payments <- reducePayments
+        (_init_payments init)
+        (_savedPayment_payment <$> addPayment)
+        (_savedPayment_payment <$> _tableOut_editPayment table)
+        (_tableOut_deletePayment table)
+
+      paymentCategories <- reducePaymentCategories
+        (_init_paymentCategories init)
+        payments
+        (_savedPayment_paymentCategory <$> addPayment)
+        (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
+        (_tableOut_deletePayment table)
+
+      (searchNameEvent, searchName) <-
+        debounceSearchName (_headerOut_searchName header)
+
+      let searchPayments =
+            getSearchPayments searchName (_headerOut_searchFrequency header) payments
+
+      header <- Header.widget $ HeaderIn
+        { _headerIn_init = init
+        , _headerIn_payments = payments
+        , _headerIn_searchPayments = searchPayments
+        , _headerIn_paymentCategories = paymentCategories
+        }
+
+      table <- Table.widget $ TableIn
+        { _tableIn_init = init
+        , _tableIn_currentPage = _pagesOut_currentPage pages
+        , _tableIn_payments = searchPayments
+        , _tableIn_perPage = paymentsPerPage
+        , _tableIn_paymentCategories = paymentCategories
+        }
+
+      pages <- Pages.widget $ PagesIn
+        { _pagesIn_total = length <$> searchPayments
+        , _pagesIn_perPage = paymentsPerPage
+        , _pagesIn_reset = R.leftmost $
+            [ () <$ searchNameEvent
+            , () <$ _headerOut_addPayment header
+            ]
+        }
+
+    pure ()
+
+debounceSearchName
+  :: forall t m. MonadWidget t m
+  => Dynamic t Text
+  -> m (Event t Text, Dynamic t Text)
+debounceSearchName searchName = do
+  event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName)
+  dynamic <- R.holdDyn "" event
+  return (event, dynamic)
+
+reducePayments
+  :: forall t m. MonadWidget t m
+  => [Payment]
+  -> Event t Payment -- add payment
+  -> Event t Payment -- edit payment
+  -> Event t Payment -- delete payment
+  -> m (Dynamic t [Payment])
+reducePayments initPayments addPayment editPayment deletePayment =
+  R.foldDyn id initPayments $ R.leftmost
+    [ (:) <$> addPayment
+    , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id))
+    , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
+    ]
+
+reducePaymentCategories
+  :: forall t m. MonadWidget t m
+  => [PaymentCategory]
+  -> Dynamic t [Payment]      -- payments
+  -> Event t PaymentCategory  -- add payment category
+  -> Event t PaymentCategory  -- edit payment category
+  -> Event t Payment          -- delete payment
+  -> m (Dynamic t [PaymentCategory])
+reducePaymentCategories
+  initPaymentCategories
+  payments
+  addPaymentCategory
+  editPaymentCategory
+  deletePayment
+    =
+  R.foldDyn id initPaymentCategories $ R.leftmost
+    [ (:) <$> addPaymentCategory
+    , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name))
+    , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
+    ]
+  where
+    deletePaymentName =
+      R.attachWithMaybe
+        (\ps p ->
+          if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then
+            Nothing
+          else
+            Just (_payment_name p))
+        (R.current payments)
+        deletePayment
+    lowerName = T.toLower . _payment_name
+
+getSearchPayments
+  :: forall t. Reflex t
+  => Dynamic t Text
+  -> Dynamic t Frequency
+  -> Dynamic t [Payment]
+  -> Dynamic t [Payment]
+getSearchPayments name frequency payments = do
+  n <- name
+  f <- frequency
+  ps <- payments
+  pure $ flip filter ps (\p ->
+    (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
+    && (_payment_frequency p == f)
+    ))
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 40bc864..bf6b604 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -30,9 +30,6 @@ import qualified View.Payment.Edit   as Edit
 import qualified Icon
 import qualified Util.Reflex         as ReflexUtil
 
--- TODO: remove
-import           Debug.Trace         (trace)
-
 data TableIn t = TableIn
   { _tableIn_init              :: Init
   , _tableIn_currentPage       :: Dynamic t Int
diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs
index c2fde58..2561156 100644
--- a/common/src/Common/Message/Key.hs
+++ b/common/src/Common/Message/Key.hs
@@ -56,6 +56,7 @@ data Key =
 
   | Income_AddLong
   | Income_AddShort
+  | Income_Name
   | Income_Amount
   | Income_Clone
   | Income_CumulativeSince Text
diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs
index 3173561..25e9f4b 100644
--- a/common/src/Common/Message/Translation.hs
+++ b/common/src/Common/Message/Translation.hs
@@ -237,10 +237,15 @@ m l Income_AddShort =
     English -> "Add"
     French  -> "Ajouter"
 
+m l Income_Name =
+  case l of
+    English -> "Name"
+    French  -> "Nom"
+
 m l Income_Amount =
   case l of
-    English -> "Amount"
-    French  -> "Montant"
+    English -> "Income"
+    French  -> "Revenu"
 
 m l Income_Clone =
   case l of
-- 
cgit v1.2.3