Remove payment category if unused after a payment is deleted

4 files changed, 58 insertions, 41 deletions

diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 915cc18..46ab642 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -45,18 +45,14 @@ widget paymentIn = do
       paymentCategories <- getPaymentCategories
         (_init_paymentCategories init)
         (_createdPayment_paymentCategory <$> _headerOut_addPayment header)
+        payments
+        (_tableOut_deletePayment table)
 
-      let searchPayments =
-            getSearchPayments
-              debouncedSearchName
-              (_headerOut_searchFrequency header)
-              payments
-
-      debouncedSearchNameEvt <-
-        R.debounce (0.5 :: NominalDiffTime) (R.updated $ _headerOut_searchName header)
+      (searchNameEvent, searchName) <-
+        debounceSearchName (_headerOut_searchName header)
 
-      debouncedSearchName <-
-        R.holdDyn "" debouncedSearchNameEvt
+      let searchPayments =
+            getSearchPayments searchName (_headerOut_searchFrequency header) payments
 
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
@@ -77,34 +73,57 @@ widget paymentIn = do
         { _pagesIn_total = length <$> searchPayments
         , _pagesIn_perPage = paymentsPerPage
         , _pagesIn_reset = R.leftmost $
-            [ const () <$> debouncedSearchNameEvt
+            [ const () <$> searchNameEvent
             , const () <$> _headerOut_addPayment header
             ]
         }
 
     pure $ PaymentOut {}
 
+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)
+
 getPayments
   :: forall t m. MonadWidget t m
   => [Payment]
   -> Event t Payment
-  -> Event t PaymentId
+  -> Event t Payment
   -> m (Dynamic t [Payment])
 getPayments initPayments addPayment deletePayment =
   R.foldDyn id initPayments $ R.leftmost
     [ (:) <$> addPayment
-    , flip fmap deletePayment (\paymentId -> filter ((/= paymentId) . _payment_id))
+    , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
     ]
 
 getPaymentCategories
   :: forall t m. MonadWidget t m
   => [PaymentCategory]
-  -> Event t PaymentCategory
+  -> Event t PaymentCategory  -- add payment category
+  -> Dynamic t [Payment]      -- payments
+  -> Event t Payment          -- delete payment
   -> m (Dynamic t [PaymentCategory])
-getPaymentCategories initPaymentCategories addPaymentCategory =
+getPaymentCategories initPaymentCategories addPaymentCategory payments deletePayment =
   R.foldDyn id initPaymentCategories $ R.leftmost
     [ (:) <$> addPaymentCategory
+    , 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
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index e0772f7..bd10e5a 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -23,7 +23,6 @@ import           Common.Model              (Category (..), CategoryId,
                                             CreatedPayment (..), Frequency (..),
                                             Payment (..), PaymentCategory (..))
 import qualified Common.Msg                as Msg
-import qualified Common.Util.Text          as Text
 import qualified Common.Util.Time          as Time
 import qualified Common.Validation.Payment as PaymentValidation
 import           Component                 (ButtonIn (..), InputIn (..),
@@ -168,4 +167,4 @@ view addIn = do
 findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
 findCategory paymentName =
   fmap _paymentCategory_category
-    . L.find ((==) (Text.formatSearch paymentName) . _paymentCategory_name)
+    . L.find ((==) (T.toLower paymentName) . _paymentCategory_name)
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 4aa10f3..65ce660 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -4,26 +4,26 @@ module View.Payment.Delete
   , DeleteOut(..)
   ) where
 
-import           Data.Text            (Text)
-import qualified Data.Text            as T
-import           Reflex.Dom           (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom           as R
-
-import           Common.Model.Payment (PaymentId)
-import qualified Common.Msg           as Msg
-import           Component            (ButtonIn (..), ButtonOut (..))
-import qualified Component            as Component
-import qualified Util.Ajax            as Ajax
-import qualified Util.Either          as EitherUtil
-import qualified Util.WaitFor         as WaitFor
+import           Data.Text    (Text)
+import qualified Data.Text    as T
+import           Reflex.Dom   (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom   as R
+
+import           Common.Model (Payment (..))
+import qualified Common.Msg   as Msg
+import           Component    (ButtonIn (..), ButtonOut (..))
+import qualified Component    as Component
+import qualified Util.Ajax    as Ajax
+import qualified Util.Either  as EitherUtil
+import qualified Util.WaitFor as WaitFor
 
 data DeleteIn t = DeleteIn
-  { _deleteIn_id :: Dynamic t PaymentId
+  { _deleteIn_payment :: Dynamic t Payment
   }
 
 data DeleteOut t = DeleteOut
   { _deleteOut_cancel   :: Event t ()
-  , _deleteOut_validate :: Event t PaymentId
+  , _deleteOut_validate :: Event t Payment
   }
 
 view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t)
@@ -47,8 +47,9 @@ view deleteIn =
               , _buttonIn_waiting = waiting
               })
 
-          let url = flip fmap (_deleteIn_id deleteIn) (\id ->
-                  T.concat ["/payment/", T.pack . show $ id]
+          let url =
+                R.ffor (_deleteIn_payment deleteIn) (\id ->
+                  T.concat ["/payment/", T.pack . show $ _payment_id id]
                 )
 
           (result, waiting) <- WaitFor.waitFor
@@ -59,5 +60,5 @@ view deleteIn =
 
       return DeleteOut
         { _deleteOut_cancel = cancel
-        , _deleteOut_validate = R.tag (R.current $ _deleteIn_id deleteIn) deletedPayment
+        , _deleteOut_validate = R.tag (R.current $ _deleteIn_payment deleteIn) deletedPayment
         }
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index cdc4bb3..b09f30f 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -13,11 +13,9 @@ import           Reflex.Dom          (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom          as R
 
 import           Common.Model        (Category (..), Init (..), Payment (..),
-                                      PaymentCategory (..), PaymentId,
-                                      User (..))
+                                      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
 import           Component           (ButtonIn (..), ButtonOut (..),
                                       ModalIn (..), ModalOut (..))
@@ -37,7 +35,7 @@ data TableIn t = TableIn
   }
 
 data TableOut t = TableOut
-  { _tableOut_deletePayment :: Event t PaymentId
+  { _tableOut_deletePayment :: Event t Payment
   }
 
 widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
@@ -84,7 +82,7 @@ paymentRow
   => Init
   -> Dynamic t [PaymentCategory]
   -> Dynamic t Payment
-  -> m (Event t PaymentId)
+  -> m (Event t Payment)
 paymentRow init paymentCategories payment =
   R.divClass "row" $ do
 
@@ -151,13 +149,13 @@ paymentRow init paymentCategories payment =
             [ _deleteOut_cancel . _modalOut_content $ modalOut
             , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut
             ]
-        , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment })
+        , _modalIn_content = Delete.view (DeleteIn { _deleteIn_payment = payment })
         }
     return (_deleteOut_validate . _modalOut_content $ modalOut)
 
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do
   paymentCategory <- L.find
-    ((== T.formatSearch paymentName) . _paymentCategory_name)
+    ((== T.toLower paymentName) . _paymentCategory_name)
     paymentCategories
   L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories