Update table when adding or removing a payment

7 files changed, 155 insertions, 78 deletions

diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 42da8fb..5245e72 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -4,17 +4,20 @@ module View.Payment
   , PaymentOut(..)
   ) where
 
+import           Data.Text           (Text)
+import qualified Data.Text           as T
 import           Prelude             hiding (init)
-import           Reflex.Dom          (MonadWidget)
+import           Reflex.Dom          (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (Init (..))
-
+import           Common.Model        (Frequency, Init (..), Payment (..),
+                                      PaymentId)
+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 (..))
+import           View.Payment.Table  (TableIn (..), TableOut (..))
 import qualified View.Payment.Table  as Table
 
 data PaymentIn = PaymentIn
@@ -32,21 +35,63 @@ widget paymentIn = do
       let init = _paymentIn_init paymentIn
           paymentsPerPage = 7
 
+      payments <- getPayments
+        (_init_payments init)
+        (_headerOut_addedPayment header)
+        (_tableOut_deletedPayment table)
+
+      let searchPayments =
+            getSearchPayments
+              (_headerOut_searchName header)
+              (_headerOut_searchFrequency header)
+              payments
+
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
+        , _headerIn_searchPayments = searchPayments
         }
 
-      _ <- Table.widget $ TableIn
+      table <- Table.widget $ TableIn
         { _tableIn_init = init
         , _tableIn_currentPage = _pagesOut_currentPage pages
-        , _tableIn_payments = _headerOut_searchPayments header
+        , _tableIn_payments = searchPayments
         , _tableIn_perPage = paymentsPerPage
         }
 
       pages <- Pages.widget $ PagesIn
-        { _pagesIn_total = length <$> _headerOut_searchPayments header
+        { _pagesIn_total = length <$> searchPayments
         , _pagesIn_perPage = paymentsPerPage
-        , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_searchName header
+        , _pagesIn_reset = R.leftmost $
+            [ fmap (const ()) . R.updated . _headerOut_searchName $ header
+            , fmap (const ()) . _headerOut_addedPayment $ header
+            ]
         }
 
     pure $ PaymentOut {}
+
+getPayments
+  :: forall t m. MonadWidget t m
+  => [Payment]
+  -> Event t Payment
+  -> Event t PaymentId
+  -> m (Dynamic t [Payment])
+getPayments initPayments addedPayment deletedPayment =
+  R.foldDyn id initPayments $ R.leftmost
+    [ flip fmap addedPayment (:)
+    , flip fmap deletedPayment (\paymentId -> filter ((/= paymentId) . _payment_id))
+    ]
+
+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/Add.hs b/client/src/View/Payment/Add.hs
index 8b1b56e..602f7f3 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -10,12 +10,12 @@ import qualified Data.Maybe             as Maybe
 import qualified Data.Text              as T
 import qualified Data.Time.Calendar     as Calendar
 import qualified Data.Time.Clock        as Time
-import           Reflex.Dom             (Event, MonadWidget)
+import           Reflex.Dom             (Event, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 import qualified Text.Read              as T
 
 import           Common.Model           (Category (..), CreatePayment (..),
-                                         Frequency (..))
+                                         Frequency (..), Payment (..))
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Time       as Time
 import           Component              (ButtonIn (..), InputIn (..),
@@ -23,48 +23,56 @@ import           Component              (ButtonIn (..), InputIn (..),
                                          SelectOut (..))
 import qualified Component              as Component
 import qualified Util.Ajax              as Ajax
+import qualified Util.Either            as EitherUtil
 import qualified Util.WaitFor           as WaitFor
 
-data AddIn = AddIn
+data AddIn t = AddIn
   { _addIn_categories :: [Category]
+  , _addIn_show       :: Event t ()
   }
 
 data AddOut t = AddOut
-  { _addOut_cancel :: Event t ()
+  { _addOut_cancel       :: Event t ()
+  , _addOut_addedPayment :: Event t Payment
   }
 
-view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t)
+view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t)
 view addIn = do
   R.divClass "add" $ do
     R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add
 
     R.divClass "addContent" $ do
-      name <- _inputOut_value <$> (Component.input $
-        Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
+      name <- _inputOut_value <$> (Component.input
+        (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
+        (_addIn_show addIn))
 
-      cost <- _inputOut_value <$> (Component.input $
-        Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
+      cost <- _inputOut_value <$> (Component.input
+        (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
+        (_addIn_show addIn))
 
       currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
 
-      date <- _inputOut_value <$> (Component.input $
-        Component.defaultInputIn
+      date <- _inputOut_value <$> (Component.input
+        (Component.defaultInputIn
           { _inputIn_label = Msg.get Msg.Payment_Date
           , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay
           , _inputIn_inputType = "date"
           , _inputIn_hasResetButton = False
           })
+        (_addIn_show addIn))
 
       frequency <- _selectOut_value <$> (Component.select $ SelectIn
         { _selectIn_label = Msg.get Msg.Payment_Frequency
         , _selectIn_initialValue = Punctual
         , _selectIn_values = R.constDyn frequencies
+        , _selectIn_reset = _addIn_show addIn
         })
 
       category <- _selectOut_value <$> (Component.select $ SelectIn
         { _selectIn_label = Msg.get Msg.Payment_Category
         , _selectIn_initialValue = 0
         , _selectIn_values = R.constDyn categories
+        , _selectIn_reset = _addIn_show addIn
         })
 
       let payment = CreatePayment
@@ -74,7 +82,7 @@ view addIn = do
             <*> category
             <*> frequency
 
-      cancel <- R.divClass "buttons" $ do
+      (addedPayment, cancel) <- R.divClass "buttons" $ do
         rec
           validate <- Component._buttonOut_clic <$> (Component.button $
             (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
@@ -83,17 +91,20 @@ view addIn = do
               , _buttonIn_submit = True
               })
 
-          (_, waiting) <- WaitFor.waitFor
+          (result, waiting) <- WaitFor.waitFor
             (Ajax.postJson "/payment")
             validate
             payment
 
-        Component._buttonOut_clic <$> (Component.button $
+        cancel <- Component._buttonOut_clic <$> (Component.button $
           (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
             { _buttonIn_class = R.constDyn "undo" })
 
+        return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
+
       return AddOut
         { _addOut_cancel = cancel
+        , _addOut_addedPayment = addedPayment
         }
 
   where
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 03cf267..330ef9f 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -4,6 +4,7 @@ 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
@@ -13,6 +14,7 @@ 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
@@ -20,7 +22,8 @@ data DeleteIn t = DeleteIn
   }
 
 data DeleteOut t = DeleteOut
-  { _deleteOut_cancel :: Event t ()
+  { _deleteOut_cancel   :: Event t ()
+  , _deleteOut_validate :: Event t PaymentId
   }
 
 view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t)
@@ -30,7 +33,7 @@ view deleteIn =
 
     R.divClass "deleteContent" $ do
 
-      cancel <- R.divClass "buttons" $ do
+      (deletedPayment, cancel) <- R.divClass "buttons" $ do
         rec
           confirm <- Component._buttonOut_clic <$> (Component.button $
             (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
@@ -41,7 +44,8 @@ view deleteIn =
           let url = flip fmap (_deleteIn_id deleteIn) (\id ->
                   T.concat ["/payment/", T.pack . show $ id]
                 )
-          Ajax.delete url confirm
+
+          result <- Ajax.delete url confirm
 
           -- (_, waiting) <- WaitFor.waitFor
           --   (Ajax.delete "/payment")
@@ -52,8 +56,9 @@ view deleteIn =
           (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
             { _buttonIn_class = R.constDyn "undo" })
 
-        return cancel
+        return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
 
       return DeleteOut
         { _deleteOut_cancel = cancel
+        , _deleteOut_validate = R.tag (R.current $ _deleteIn_id deleteIn) deletedPayment
         }
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index be7f6d5..653df5e 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -13,7 +13,7 @@ import           Data.Text              (Text)
 import qualified Data.Text              as T
 import qualified Data.Time              as Time
 import           Prelude                hiding (init)
-import           Reflex.Dom             (Dynamic, MonadWidget, Reflex)
+import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 
 import           Common.Model           (Category, Currency,
@@ -22,7 +22,6 @@ import           Common.Model           (Category, Currency,
                                          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 (..),
@@ -34,44 +33,47 @@ import           View.Payment.Add       (AddIn (..), AddOut (..))
 import qualified View.Payment.Add       as Add
 
 data HeaderIn t = HeaderIn
-  { _headerIn_init :: Init
+  { _headerIn_init           :: Init
+  , _headerIn_searchPayments :: Dynamic t [Payment]
   }
 
 data HeaderOut t = HeaderOut
-  { _headerOut_searchName     :: Dynamic t Text
-  , _headerOut_searchPayments :: Dynamic t [Payment]
+  { _headerOut_searchName      :: Dynamic t Text
+  , _headerOut_searchFrequency :: Dynamic t Frequency
+  , _headerOut_addedPayment    :: Event t Payment
   }
 
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    payerAndAdd incomes punctualPayments users categories currency
-    (searchName, searchFrequency)  <- searchLine
-    let searchPayments = getSearchPayments searchName searchFrequency payments
-    infos searchPayments users currency
+    addedPayment <- payerAndAdd incomes punctualPayments users categories currency
+    let resetSearchName = fmap (const ()) $ addedPayment
+    (searchName, searchFrequency)  <- searchLine resetSearchName
+
+    infos (_headerIn_searchPayments headerIn) users currency
+
     return $ HeaderOut
       { _headerOut_searchName = searchName
-      , _headerOut_searchPayments = searchPayments
+      , _headerOut_searchFrequency = searchFrequency
+      , _headerOut_addedPayment = addedPayment
       }
   where
     init = _headerIn_init headerIn
     incomes = _init_incomes init
-    payments = _init_payments init
-    punctualPayments = filter ((==) Punctual . _payment_frequency) payments
+    initPayments = _init_payments init
+    punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments
     users = _init_users init
     categories = _init_categories init
     currency = _init_currency init
 
-getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment]
-getSearchPayments name frequency payments = do
-  n <- name
-  f <- frequency
-  pure $ flip filter payments (\p ->
-    (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
-    && (_payment_frequency p == f)
-    ))
-
-payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m ()
+payerAndAdd
+  :: forall t m. MonadWidget t m
+  => [Income]
+  -> [Payment]
+  -> [User]
+  -> [Category]
+  -> Currency
+  -> m (Event t Payment)
 payerAndAdd incomes payments users categories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
@@ -94,19 +96,28 @@ payerAndAdd incomes payments users categories currency = do
       , _buttonIn_submit = False
       })
     rec
-      modalOut <- Component.modal $ ModalIn
+      modalOut <- fmap _modalOut_content . Component.modal $ ModalIn
         { _modalIn_show    = addPaymentClic
-        , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut
-        , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories }
+        , _modalIn_hide = R.leftmost $
+            [ _addOut_cancel modalOut
+            , fmap (const ()) . _addOut_addedPayment $ modalOut
+            ]
+        , _modalIn_content = Add.view $ AddIn
+            { _addIn_categories = categories
+            , _addIn_show = addPaymentClic
+            }
         }
-    return ()
+    return (_addOut_addedPayment modalOut)
 
-searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency)
-searchLine = do
+searchLine
+  :: forall t m. MonadWidget t m
+  => Event t ()
+  -> m (Dynamic t Text, Dynamic t Frequency)
+searchLine reset = do
   R.divClass "searchLine" $ do
-    searchName <- _inputOut_value <$> (Component.input $ Component.defaultInputIn
-      { _inputIn_label = Msg.get Msg.Search_Name
-      })
+    searchName <- _inputOut_value <$> (Component.input
+      ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name })
+      reset)
 
     let frequencies = M.fromList
           [ (Punctual, Msg.get Msg.Payment_PunctualMale)
@@ -118,7 +129,11 @@ searchLine = do
 
     return (searchName, searchFrequency)
 
-infos :: forall t m. MonadWidget t m => Dynamic t [Payment] -> [User] -> Currency -> m ()
+infos
+  :: forall t m. MonadWidget t m
+  => Dynamic t [Payment]
+  -> [User]
+  -> Currency -> m ()
 infos payments users currency =
   R.divClass "infos" $ do
 
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index d14b640..57d67ac 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -64,7 +64,7 @@ pageButtons total perPage reset = do
     return currentPage
 
     where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage)
-          pageEvent = R.switchPromptlyDyn . fmap R.leftmost
+          pageEvent = R.switch . R.current . fmap R.leftmost
           noCurrentPage = R.constDyn Nothing
 
 range :: Int -> Int -> [Int]
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 13cedda..ba16bf5 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -9,11 +9,12 @@ import qualified Data.Map            as M
 import           Data.Text           (Text)
 import qualified Data.Text           as T
 import           Prelude             hiding (init)
-import           Reflex.Dom          (Dynamic, MonadWidget)
+import           Reflex.Dom          (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom          as R
 
 import           Common.Model        (Category (..), Init (..), Payment (..),
-                                      PaymentCategory (..), User (..))
+                                      PaymentCategory (..), PaymentId,
+                                      User (..))
 import qualified Common.Model        as CM
 import qualified Common.Msg          as Msg
 import qualified Common.Util.Text    as T
@@ -34,15 +35,15 @@ data TableIn t = TableIn
   , _tableIn_perPage     :: Int
   }
 
-data TableOut = TableOut
-  {
+data TableOut t = TableOut
+  { _tableOut_deletedPayment :: Event t PaymentId
   }
 
-widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut
+widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
 widget tableIn = do
   R.divClass "table" $ do
 
-    R.divClass "lines" $ do
+    deletedPayment <- R.divClass "lines" $ do
       R.divClass "header" $ do
         R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
         R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost
@@ -52,13 +53,14 @@ widget tableIn = do
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
-      _ <- R.simpleList paymentRange (paymentRow init)
-      return ()
+      (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init))
 
     Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
       R.text $ Msg.get Msg.Payment_Empty
 
-  return $ TableOut {}
+    return $ TableOut
+      { _tableOut_deletedPayment = deletedPayment
+      }
 
   where
     init = _tableIn_init tableIn
@@ -74,7 +76,7 @@ getPaymentRange perPage payments currentPage =
     . L.sortOn _payment_date
     $ payments
 
-paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m ()
+paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId)
 paymentRow init payment =
   R.divClass "row" $ do
     R.divClass "cell name" . R.dynText . fmap _payment_name $ payment
@@ -117,10 +119,13 @@ paymentRow init payment =
     rec
       modalOut <- Component.modal $ ModalIn
         { _modalIn_show    = deletePayment
-        , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut
+        , _modalIn_hide = R.leftmost $
+            [ _deleteOut_cancel . _modalOut_content $ modalOut
+            , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut
+            ]
         , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment })
         }
-    return ()
+    return (_deleteOut_validate . _modalOut_content $ modalOut)
 
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 24e5be0..7f53299 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -28,13 +28,9 @@ view signInMessage =
   R.divClass "signIn" $
     Component.form $ do
       rec
-        input <- Component.input $ InputIn
-          { _inputIn_reset = R.ffilter Either.isRight signInResult
-          , _inputIn_hasResetButton = True
-          , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
-          , _inputIn_initialValue = ""
-          , _inputIn_inputType = "text"
-          }
+        input <- (Component.input
+          (Component.defaultInputIn { _inputIn_label = Msg.get Msg.SignIn_EmailLabel })
+          (R.ffilter Either.isRight signInResult))
 
         button <- Component.button $
           (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button))