Update category according to payment in add overlay

7 files changed, 97 insertions, 35 deletions

diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 9f671d3..43a8a6e 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -16,6 +16,7 @@ import qualified Common.Msg as Msg
 data (Reflex t) => SelectIn t a b c = SelectIn
   { _selectIn_label        :: Text
   , _selectIn_initialValue :: a
+  , _selectIn_value        :: Event t a
   , _selectIn_values       :: Dynamic t (Map a Text)
   , _selectIn_reset        :: Event t b
   , _selectIn_isValid      :: a -> Bool
@@ -48,11 +49,16 @@ select selectIn = do
 
       let initialValue = _selectIn_initialValue selectIn
 
+      let setValue = R.leftmost
+            [ const initialValue <$> (_selectIn_reset selectIn)
+            , _selectIn_value selectIn
+            ]
+
       value <- R._dropdown_value <$>
         R.dropdown
           initialValue
           (_selectIn_values selectIn)
-          (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) })
+          (R.def { R._dropdownConfig_setValue = setValue })
 
       errorMessage <- R.holdDyn "" $ R.attachWith
         (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!")
diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index e2a3dcb..fc13f36 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -1,7 +1,8 @@
 module Util.Validation
-  ( fireValidation
+  ( nelError
+  , toMaybe
+  , fireValidation
   , fireMaybe
-  , nelError
   ) where
 
 import           Control.Monad      (join)
@@ -16,6 +17,10 @@ import qualified Reflex.Dom         as R
 nelError :: Validation a b -> Validation (NonEmpty a) b
 nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success
 
+toMaybe :: Validation a b -> Maybe b
+toMaybe (Success s) = Just s
+toMaybe (Failure _) = Nothing
+
 fireValidation
   :: forall t a b c. Reflex t
   => Dynamic t (Maybe (Validation a b))
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index f614936..05eedab 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -54,6 +54,7 @@ widget paymentIn = do
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
         , _headerIn_searchPayments = searchPayments
+        , _headerIn_paymentCategories = paymentCategories
         }
 
       table <- Table.widget $ TableIn
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 2970394..d023613 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -4,21 +4,26 @@ module View.Payment.Add
   , AddOut(..)
   ) where
 
+import           Control.Monad             (join)
 import           Control.Monad.IO.Class    (liftIO)
+import qualified Data.List                 as L
 import qualified Data.Map                  as M
 import qualified Data.Maybe                as Maybe
+import           Data.Text                 (Text)
 import qualified Data.Text                 as T
 import qualified Data.Time.Calendar        as Calendar
 import qualified Data.Time.Clock           as Time
 import qualified Data.Validation           as V
-import           Reflex.Dom                (Event, MonadWidget, Reflex)
+import           Reflex.Dom                (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom                as R
 import qualified Text.Read                 as T
 
-import           Common.Model              (Category (..), CreatePayment (..),
+import           Common.Model              (Category (..), CategoryId,
+                                            CreatePayment (..),
                                             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 (..),
@@ -31,8 +36,9 @@ import qualified Util.Validation           as ValidationUtil
 import qualified Util.WaitFor              as WaitFor
 
 data AddIn t = AddIn
-  { _addIn_categories :: [Category]
-  , _addIn_cancel     :: Event t ()
+  { _addIn_categories        :: [Category]
+  , _addIn_paymentCategories :: Dynamic t [PaymentCategory]
+  , _addIn_cancel            :: Event t ()
   }
 
 data AddOut t = AddOut
@@ -54,13 +60,13 @@ view addIn = do
               , const "" <$> _addIn_cancel addIn
               ]
 
-        name <- _inputOut_value <$> (Component.input
+        name <- Component.input
           (Component.defaultInputIn
             { _inputIn_label = Msg.get Msg.Payment_Name
             , _inputIn_validation = PaymentValidation.name
             })
           reset
-          validate)
+          validate
 
         cost <- _inputOut_value <$> (Component.input
           (Component.defaultInputIn
@@ -90,15 +96,22 @@ view addIn = do
         frequency <- _selectOut_value <$> (Component.select $ SelectIn
           { _selectIn_label = Msg.get Msg.Payment_Frequency
           , _selectIn_initialValue = Punctual
+          , _selectIn_value = R.never
           , _selectIn_values = R.constDyn frequencies
           , _selectIn_reset = reset
           , _selectIn_isValid = const True
           , _selectIn_validate = validate
           })
 
+        let setCategory =
+              R.fmapMaybe id
+                . R.updated
+                $ findCategory <$> (_inputOut_raw name) <*> (_addIn_paymentCategories addIn)
+
         category <- _selectOut_value <$> (Component.select $ SelectIn
           { _selectIn_label = Msg.get Msg.Payment_Category
           , _selectIn_initialValue = -1
+          , _selectIn_value = setCategory
           , _selectIn_values = R.constDyn categories
           , _selectIn_reset = reset
           , _selectIn_isValid = \id -> id /= -1
@@ -106,7 +119,7 @@ view addIn = do
           })
 
         let payment = do
-              n <- name
+              n <- _inputOut_value name
               c <- cost
               d <- date
               cat <- category
@@ -154,3 +167,9 @@ view addIn = do
 
     categories = M.fromList . flip map (_addIn_categories addIn) $ \c ->
       (_category_id c, _category_name c)
+
+
+findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
+findCategory paymentName =
+  fmap _paymentCategory_category
+    . L.find ((==) (Text.formatSearch paymentName) . _paymentCategory_name)
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 81c7c57..4aa10f3 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -34,6 +34,11 @@ view deleteIn =
     R.divClass "deleteContent" $ do
 
       (deletedPayment, cancel) <- R.divClass "buttons" $ do
+
+        cancel <- Component._buttonOut_clic <$> (Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { _buttonIn_class = R.constDyn "undo" })
+
         rec
           confirm <- Component._buttonOut_clic <$> (Component.button $
             (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
@@ -50,10 +55,6 @@ view deleteIn =
             (Ajax.delete url)
             confirm
 
-        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 DeleteOut
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index c49b284..5cc362a 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -20,7 +20,8 @@ import qualified Reflex.Dom             as R
 import           Common.Model           (Category, CreatedPayment (..),
                                          Currency, ExceedingPayer (..),
                                          Frequency (..), Income (..), Init (..),
-                                         Payment (..), User (..))
+                                         Payment (..), PaymentCategory,
+                                         User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
@@ -34,8 +35,9 @@ import           View.Payment.Add       (AddIn (..), AddOut (..))
 import qualified View.Payment.Add       as Add
 
 data HeaderIn t = HeaderIn
-  { _headerIn_init           :: Init
-  , _headerIn_searchPayments :: Dynamic t [Payment]
+  { _headerIn_init              :: Init
+  , _headerIn_searchPayments    :: Dynamic t [Payment]
+  , _headerIn_paymentCategories :: Dynamic t [PaymentCategory]
   }
 
 data HeaderOut t = HeaderOut
@@ -47,7 +49,7 @@ data HeaderOut t = HeaderOut
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    addPayment <- payerAndAdd incomes punctualPayments users categories currency
+    addPayment <- payerAndAdd incomes punctualPayments users categories paymentCategories currency
     let resetSearchName = fmap (const ()) $ addPayment
     (searchName, searchFrequency)  <- searchLine resetSearchName
 
@@ -66,6 +68,7 @@ widget headerIn =
     users = _init_users init
     categories = _init_categories init
     currency = _init_currency init
+    paymentCategories = _headerIn_paymentCategories headerIn
 
 payerAndAdd
   :: forall t m. MonadWidget t m
@@ -73,9 +76,10 @@ payerAndAdd
   -> [Payment]
   -> [User]
   -> [Category]
+  -> Dynamic t [PaymentCategory]
   -> Currency
   -> m (Event t CreatedPayment)
-payerAndAdd incomes payments users categories currency = do
+payerAndAdd incomes payments users categories paymentCategories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
     R.divClass "exceedingPayers" $
@@ -105,6 +109,7 @@ payerAndAdd incomes payments users categories currency = do
             ]
         , _modalIn_content = Add.view $ AddIn
             { _addIn_categories = categories
+            , _addIn_paymentCategories = paymentCategories
             , _addIn_cancel = _modalOut_hide modalOut
             }
         }
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 6432274..cdc4bb3 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -26,7 +26,7 @@ import           View.Payment.Delete (DeleteIn (..), DeleteOut (..))
 import qualified View.Payment.Delete as Delete
 
 import qualified Icon
-import qualified Util.Dom            as Dom
+import qualified Util.Dom            as DomUtil
 
 data TableIn t = TableIn
   { _tableIn_init              :: Init
@@ -57,7 +57,7 @@ widget tableIn = do
       (R.switch . R.current . fmap R.leftmost) <$>
         (R.simpleList paymentRange (paymentRow init paymentCategories))
 
-    Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
+    DomUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
       R.text $ Msg.get Msg.Payment_Empty
 
     return $ TableOut
@@ -79,13 +79,24 @@ getPaymentRange perPage payments currentPage =
     . L.sortOn _payment_date
     $ payments
 
-paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId)
+paymentRow
+  :: forall t m. MonadWidget t m
+  => Init
+  -> Dynamic t [PaymentCategory]
+  -> Dynamic t Payment
+  -> m (Event t PaymentId)
 paymentRow init paymentCategories payment =
   R.divClass "row" $ do
-    R.divClass "cell name" . R.dynText . fmap _payment_name $ payment
-    R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $  payment
 
-    let user = flip fmap payment $ \p -> CM.findUser (_payment_user p) (_init_users init)
+    R.divClass "cell name" $
+      R.dynText $ fmap _payment_name payment
+
+    R.divClass "cell cost" $
+      R.dynText $ fmap (Format.price (_init_currency init) . _payment_cost) payment
+
+    let user = R.ffor payment (\p ->
+          CM.findUser (_payment_user p) (_init_users init))
+
     R.divClass "cell user" $
       R.dynText $ flip fmap user $ \mbUser -> case mbUser of
         Just u -> _user_name u
@@ -95,13 +106,16 @@ paymentRow init paymentCategories payment =
           p <- payment
           pcs <- paymentCategories
           return $ findCategory (_init_categories init) pcs (_payment_name p)
+
     R.divClass "cell category" $ do
+
       let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of
             Just c -> M.fromList
               [ ("class", "tag")
               , ("style", T.concat [ "background-color: ", _category_color c ])
               ]
             Nothing -> M.singleton "display" "none"
+
       R.elDynAttr "span" attrs $
         R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of
           Just c -> _category_name c
@@ -110,15 +124,26 @@ paymentRow init paymentCategories payment =
     R.divClass "cell date" $ do
       R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment
       R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment
-    R.divClass "cell button" . R.el "button" $ Icon.clone
-    let modifyAttrs = flip fmap payment $ \p ->
-          M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")]
-    R.elDynAttr "div" modifyAttrs $
-      R.el "button" $ Icon.edit
-    deletePayment <- R.elDynAttr "div" modifyAttrs $
-      _buttonOut_clic <$> (Component.button $
-        (Component.defaultButtonIn Icon.delete)
-          { _buttonIn_class = R.constDyn "deletePayment" })
+
+    R.divClass "cell button" $
+      R.el "button" Icon.clone
+
+    let isFromCurrentUser =
+          R.ffor
+            payment
+            (\p -> _payment_user p == _init_currentUser init)
+
+    R.divClass "cell button" $
+      DomUtil.divVisibleIf isFromCurrentUser $
+        R.el "button" Icon.edit
+
+    deletePayment <-
+      R.divClass "cell button" $
+        DomUtil.divVisibleIf isFromCurrentUser $
+          _buttonOut_clic <$> (Component.button $
+            (Component.defaultButtonIn Icon.delete)
+              { _buttonIn_class = R.constDyn "deletePayment" })
+
     rec
       modalOut <- Component.modal $ ModalIn
         { _modalIn_show    = deletePayment
@@ -133,6 +158,6 @@ paymentRow init paymentCategories payment =
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do
   paymentCategory <- L.find
-    ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name)
+    ((== T.formatSearch paymentName) . _paymentCategory_name)
     paymentCategories
   L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories