aboutsummaryrefslogtreecommitdiff
path: root/client/src/View/Payment
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/View/Payment')
-rw-r--r--client/src/View/Payment/Add.hs39
-rw-r--r--client/src/View/Payment/Delete.hs13
-rw-r--r--client/src/View/Payment/Header.hs79
-rw-r--r--client/src/View/Payment/Pages.hs2
-rw-r--r--client/src/View/Payment/Table.hs29
5 files changed, 99 insertions, 63 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 06:50:36 +0000