aboutsummaryrefslogtreecommitdiff
path: root/client
diff options
context:
space:
mode:
Diffstat (limited to 'client')
-rw-r--r--client/client.cabal6
-rw-r--r--client/src/Component/Modal.hs2
-rw-r--r--client/src/Component/Table.hs21
-rw-r--r--client/src/View/App.hs7
-rw-r--r--client/src/View/Income/Form.hs18
-rw-r--r--client/src/View/Income/Table.hs8
-rw-r--r--client/src/View/Payment/Add.hs55
-rw-r--r--client/src/View/Payment/Clone.hs61
-rw-r--r--client/src/View/Payment/Delete.hs58
-rw-r--r--client/src/View/Payment/Edit.hs56
-rw-r--r--client/src/View/Payment/Form.hs137
-rw-r--r--client/src/View/Payment/Header.hs8
-rw-r--r--client/src/View/Payment/Pages.hs87
-rw-r--r--client/src/View/Payment/Payment.hs367
-rw-r--r--client/src/View/Payment/Reducer.hs66
-rw-r--r--client/src/View/Payment/Table.hs315
16 files changed, 517 insertions, 755 deletions
diff --git a/client/client.cabal b/client/client.cabal
index 04c8543..75c2c1b 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -75,14 +75,10 @@ Executable client
View.Income.Reducer
View.Income.Table
View.NotFound
- View.Payment.Add
- View.Payment.Clone
- View.Payment.Delete
- View.Payment.Edit
View.Payment.Form
View.Payment.Header
View.Payment.Init
- View.Payment.Pages
View.Payment.Payment
+ View.Payment.Reducer
View.Payment.Table
View.SignIn
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index b0533e2..08f2e74 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -72,7 +72,7 @@ view input = do
let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn
-- Delay the event in order to let time for the modal to disappear
- R.delay (0.3 :: NominalDiffTime) content
+ R.delay (0.5 :: NominalDiffTime) content
getAttributes :: Text -> LM.Map Text Text
getAttributes modalClass =
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index 3b9ec24..2869c2d 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -4,7 +4,7 @@ module Component.Table
, Out(..)
) where
-import qualified Data.Map as M
+import qualified Data.Map as M
import Data.Text (Text)
import Reflex.Dom (Event, MonadWidget)
import qualified Reflex.Dom as R
@@ -14,23 +14,23 @@ import qualified Component.Modal as Modal
import qualified Util.Reflex as ReflexUtil
import qualified View.Icon as Icon
-data In m t h r a = In
+data In m t h r a b c = In
{ _in_headerLabel :: h -> Text
, _in_rows :: [r]
- , _in_cell :: h -> r -> Text
+ , _in_cell :: h -> r -> m ()
, _in_cloneModal :: r -> Modal.Content t m a
- , _in_editModal :: r -> Modal.Content t m a
- , _in_deleteModal :: r -> Modal.Content t m a
+ , _in_editModal :: r -> Modal.Content t m b
+ , _in_deleteModal :: r -> Modal.Content t m c
, _in_isOwner :: r -> Bool
}
-data Out t a = Out
+data Out t a b c = Out
{ _out_add :: Event t a
- , _out_edit :: Event t a
- , _out_delete :: Event t a
+ , _out_edit :: Event t b
+ , _out_delete :: Event t c
}
-view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h) => In m t h r a -> m (Out t a)
+view :: forall t m h r a b c. (MonadWidget t m, Bounded h, Enum h) => In m t h r a b c-> m (Out t a b c)
view input =
R.divClass "table" $ do
rec
@@ -49,8 +49,7 @@ view input =
R.divClass "row" $ do
flip mapM_ [minBound..] $ \header ->
R.divClass "cell" $
- R.text $
- _in_cell input header row
+ _in_cell input header row
cloneButton <-
R.divClass "cell button" $
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index d305d00..2b346af 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -58,15 +58,14 @@ widget initResult =
signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
signedWidget init route = do
R.dyn . R.ffor route $ \case
- RootRoute -> do
- paymentInit <- Payment.init
+ RootRoute ->
Payment.view $ Payment.In
{ Payment._in_currentUser = _init_currentUser init
, Payment._in_currency = _init_currency init
- , Payment._in_init = paymentInit
+ , Payment._in_users = _init_users init
}
- IncomeRoute -> do
+ IncomeRoute ->
Income.view $ Income.In
{ Income._in_currentUser = _init_currentUser init
, Income._in_currency = _init_currency init
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
index a4f7de8..ff6e55e 100644
--- a/client/src/View/Income/Form.hs
+++ b/client/src/View/Income/Form.hs
@@ -27,7 +27,7 @@ import qualified Component.Modal as Modal
import qualified Component.ModalForm as ModalForm
import qualified Util.Ajax as Ajax
-data In t = In
+data In = In
{ _in_operation :: Operation
}
@@ -36,7 +36,7 @@ data Operation
| Clone Income
| Edit Income
-view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Income
+view :: forall t m a. MonadWidget t m => In -> Modal.Content t m Income
view input cancel = do
rec
@@ -94,14 +94,14 @@ view input cancel = do
amount =
case op of
- New -> ""
- Clone income -> T.pack . show . _income_amount $ income
- Edit income -> T.pack . show . _income_amount $ income
+ New -> ""
+ Clone i -> T.pack . show . _income_amount $ i
+ Edit i -> T.pack . show . _income_amount $ i
date currentDay =
case op of
- Edit income -> _income_date income
- _ -> currentDay
+ Edit i -> _income_date i
+ _ -> currentDay
ajax =
case op of
@@ -115,5 +115,5 @@ view input cancel = do
mkPayload =
case op of
- Edit income -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id income) a b
- _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b
+ Edit i -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id i) a b
+ _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 32ab27b..c623acb 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -80,14 +80,14 @@ headerLabel UserHeader = Msg.get Msg.Income_Name
headerLabel DateHeader = Msg.get Msg.Income_Date
headerLabel AmountHeader = Msg.get Msg.Income_Amount
-cell :: [User] -> Currency -> Header -> Income -> Text
+cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Income -> m ()
cell users currency header income =
case header of
UserHeader ->
- Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users
+ R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users
DateHeader ->
- Format.longDay . _income_date $ income
+ R.text . Format.longDay . _income_date $ income
AmountHeader ->
- Format.price currency . _income_amount $ income
+ R.text . Format.price currency . _income_amount $ income
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
deleted file mode 100644
index e983465..0000000
--- a/client/src/View/Payment/Add.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-module View.Payment.Add
- ( view
- , In(..)
- ) where
-
-import Control.Monad (join)
-import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text as T
-import qualified Data.Time.Clock as Time
-import Reflex.Dom (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom as R
-
-import Common.Model (Category (..), CreatePaymentForm (..),
- Frequency (..), Payment (..),
- PaymentCategory (..),
- SavedPayment (..))
-import qualified Common.Msg as Msg
-import qualified Common.Util.Time as TimeUtil
-import qualified Component.Modal as Modal
-import qualified Util.Ajax as Ajax
-import qualified Util.Reflex as ReflexUtil
-import qualified View.Payment.Form as Form
-
-data In t = In
- { _in_categories :: [Category]
- , _in_paymentCategories :: Dynamic t [PaymentCategory]
- , _in_frequency :: Dynamic t Frequency
- }
-
-view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment
-view input cancel = do
-
- currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
-
- formOutput <- R.dyn $ do
- paymentCategories <- _in_paymentCategories input
- frequency <- _in_frequency input
- return $ Form.view $ Form.In
- { Form._in_cancel = cancel
- , Form._in_headerLabel = Msg.get Msg.Payment_Add
- , Form._in_categories = _in_categories input
- , Form._in_paymentCategories = paymentCategories
- , Form._in_name = ""
- , Form._in_cost = ""
- , Form._in_date = currentDay
- , Form._in_category = -1
- , Form._in_frequency = frequency
- , Form._in_mkPayload = CreatePaymentForm
- , Form._in_ajax = Ajax.post
- }
-
- hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
- addPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput)
-
- return (hide, addPayment)
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
deleted file mode 100644
index 82b0c27..0000000
--- a/client/src/View/Payment/Clone.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-module View.Payment.Clone
- ( In(..)
- , view
- ) where
-
-import qualified Control.Monad as Monad
-import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text as T
-import qualified Data.Time.Clock as Time
-import Reflex.Dom (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom as R
-
-import Common.Model (Category (..), CategoryId,
- CreatePaymentForm (..), Frequency (..),
- Payment (..), PaymentCategory (..),
- SavedPayment (..))
-import qualified Common.Msg as Msg
-import qualified Common.Util.Time as TimeUtil
-import qualified Component.Modal as Modal
-import qualified Util.Ajax as Ajax
-import qualified Util.Reflex as ReflexUtil
-import qualified View.Payment.Form as Form
-
-data In t = In
- { _in_show :: Event t ()
- , _in_categories :: [Category]
- , _in_paymentCategories :: Dynamic t [PaymentCategory]
- , _in_payment :: Dynamic t Payment
- , _in_category :: Dynamic t CategoryId
- }
-
-view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment
-view input cancel = do
-
- currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
-
- form <- R.dyn $ do
- paymentCategories <- _in_paymentCategories input
- payment <- _in_payment input
- category <- _in_category input
- return . Form.view $ Form.In
- { Form._in_cancel = cancel
- , Form._in_headerLabel = Msg.get Msg.Payment_CloneLong
- , Form._in_categories = _in_categories input
- , Form._in_paymentCategories = paymentCategories
- , Form._in_name = _payment_name payment
- , Form._in_cost = T.pack . show . _payment_cost $ payment
- , Form._in_date = currentDay
- , Form._in_category = category
- , Form._in_frequency = _payment_frequency payment
- , Form._in_mkPayload = CreatePaymentForm
- , Form._in_ajax = Ajax.post
- }
-
- hide <- ReflexUtil.flatten (Form._output_hide <$> form)
- clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> form)
-
- return $
- ( hide
- , clonePayment
- )
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
deleted file mode 100644
index e5e7219..0000000
--- a/client/src/View/Payment/Delete.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-module View.Payment.Delete
- ( In(..)
- , view
- ) 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 (..))
-import qualified Common.Msg as Msg
-import qualified Component.Button as Button
-import qualified Component.Modal as Modal
-import qualified Util.Ajax as Ajax
-import qualified Util.Either as EitherUtil
-import qualified Util.WaitFor as WaitFor
-
-data In t = In
- { _in_payment :: Dynamic t Payment
- }
-
-view :: forall t m. MonadWidget t m => (In t) -> Modal.Content t m Payment
-view input _ =
- R.divClass "delete" $ do
- R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
-
- R.divClass "deleteContent" $ do
-
- (confirm, cancel) <- R.divClass "buttons" $ do
-
- cancel <- Button._out_clic <$> (Button.view $
- (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
- { Button._in_class = R.constDyn "undo" })
-
- rec
- confirm <- Button._out_clic <$> (Button.view $
- (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm))
- { Button._in_class = R.constDyn "confirm"
- , Button._in_submit = True
- , Button._in_waiting = waiting
- })
-
- let url =
- R.ffor (_in_payment input) (\id ->
- T.concat ["/api/payment/", T.pack . show $ _payment_id id]
- )
-
- (result, waiting) <- WaitFor.waitFor
- (Ajax.delete url)
- confirm
-
- return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
-
- return $
- ( R.leftmost [ cancel, () <$ confirm ]
- , R.tag (R.current $ _in_payment input) confirm
- )
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
deleted file mode 100644
index 5cb4537..0000000
--- a/client/src/View/Payment/Edit.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-module View.Payment.Edit
- ( In(..)
- , view
- ) where
-
-import qualified Control.Monad as Monad
-import qualified Data.Text as T
-import Reflex.Dom (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom as R
-
-import Common.Model (Category (..), CategoryId,
- EditPaymentForm (..), Frequency (..),
- Payment (..), PaymentCategory (..),
- SavedPayment (..))
-import qualified Common.Msg as Msg
-import qualified Component.Modal as Modal
-import qualified Util.Ajax as Ajax
-import qualified Util.Reflex as ReflexUtil
-import qualified View.Payment.Form as Form
-
-data In t = In
- { _in_show :: Event t ()
- , _in_categories :: [Category]
- , _in_paymentCategories :: Dynamic t [PaymentCategory]
- , _in_payment :: Dynamic t Payment
- , _in_category :: Dynamic t CategoryId
- }
-
-view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment
-view input cancel = do
-
- formOutput <- R.dyn $ do
- paymentCategories <- _in_paymentCategories input
- payment <- _in_payment input
- category <- _in_category input
- return . Form.view $ Form.In
- { Form._in_cancel = cancel
- , Form._in_headerLabel = Msg.get Msg.Payment_EditLong
- , Form._in_categories = _in_categories input
- , Form._in_paymentCategories = paymentCategories
- , Form._in_name = _payment_name payment
- , Form._in_cost = T.pack . show . _payment_cost $ payment
- , Form._in_date = _payment_date payment
- , Form._in_category = category
- , Form._in_frequency = _payment_frequency payment
- , Form._in_mkPayload = EditPaymentForm (_payment_id payment)
- , Form._in_ajax = Ajax.put
- }
-
- hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
- editPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput)
-
- return $
- ( hide
- , editPayment
- )
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 29768aa..99b0848 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -1,10 +1,12 @@
module View.Payment.Form
( view
, In(..)
- , Out(..)
+ , Operation(..)
) where
-import Data.Aeson (ToJSON)
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson (Value)
+import qualified Data.Aeson as Aeson
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as M
@@ -13,6 +15,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import qualified Data.Time.Calendar as Calendar
+import qualified Data.Time.Clock as Clock
import Data.Validation (Validation)
import qualified Data.Validation as V
import Reflex.Dom (Dynamic, Event, MonadWidget)
@@ -20,103 +23,98 @@ import qualified Reflex.Dom as R
import qualified Text.Read as T
import Common.Model (Category (..), CategoryId,
+ CreatePaymentForm (..),
+ EditPaymentForm (..),
Frequency (..), Payment (..),
PaymentCategory (..),
SavedPayment (..))
import qualified Common.Msg as Msg
+import qualified Common.Util.Time as TimeUtil
import qualified Common.Validation.Payment as PaymentValidation
+
import qualified Component.Input as Input
+import qualified Component.Modal as Modal
import qualified Component.ModalForm as ModalForm
import qualified Component.Select as Select
+import qualified Util.Ajax as Ajax
import qualified Util.Validation as ValidationUtil
-data In m t a = In
- { _in_cancel :: Event t ()
- , _in_headerLabel :: Text
- , _in_categories :: [Category]
+data In = In
+ { _in_categories :: [Category]
, _in_paymentCategories :: [PaymentCategory]
- , _in_name :: Text
- , _in_cost :: Text
- , _in_date :: Day
- , _in_category :: CategoryId
- , _in_frequency :: Frequency
- , _in_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a
- , _in_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment))
+ , _in_operation :: Operation
}
-data Out t = Out
- { _output_hide :: Event t ()
- , _output_addPayment :: Event t SavedPayment
- }
+data Operation
+ = New Frequency
+ | Clone Payment
+ | Edit Payment
-view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t)
-view input = do
+view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment
+view input cancel = do
rec
let reset = R.leftmost
[ "" <$ ModalForm._out_cancel modalForm
, "" <$ ModalForm._out_validate modalForm
- , "" <$ _in_cancel input
+ , "" <$ cancel
]
modalForm <- ModalForm.view $ ModalForm.In
- { ModalForm._in_headerLabel = _in_headerLabel input
- , ModalForm._in_ajax = _in_ajax input "/api/payment"
+ { ModalForm._in_headerLabel = headerLabel
+ , ModalForm._in_ajax = ajax "/api/payment"
, ModalForm._in_form = form reset (ModalForm._out_confirm modalForm)
}
- return $ Out
- { _output_hide = ModalForm._out_hide modalForm
- , _output_addPayment = ModalForm._out_validate modalForm
- }
+ return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm)
where
+
form
:: Event t String
-> Event t ()
- -> m (Dynamic t (Validation (NonEmpty Text) a))
+ -> m (Dynamic t (Validation (NonEmpty Text) Value))
form reset confirm = do
name <- Input.view
(Input.defaultIn
{ Input._in_label = Msg.get Msg.Payment_Name
- , Input._in_initialValue = _in_name input
+ , Input._in_initialValue = name
, Input._in_validation = PaymentValidation.name
})
- (_in_name input <$ reset)
+ (name <$ reset)
confirm
cost <- Input._out_raw <$> (Input.view
(Input.defaultIn
{ Input._in_label = Msg.get Msg.Payment_Cost
- , Input._in_initialValue = _in_cost input
+ , Input._in_initialValue = cost
, Input._in_validation = PaymentValidation.cost
})
- (_in_cost input <$ reset)
+ (cost <$ reset)
confirm)
- let initialDate = T.pack . Calendar.showGregorian . _in_date $ input
+ d <- date
date <- Input._out_raw <$> (Input.view
(Input.defaultIn
{ Input._in_label = Msg.get Msg.Payment_Date
- , Input._in_initialValue = initialDate
+ , Input._in_initialValue = d
, Input._in_inputType = "date"
, Input._in_hasResetButton = False
, Input._in_validation = PaymentValidation.date
})
- (initialDate <$ reset)
+ (d <$ reset)
confirm)
let setCategory =
R.fmapMaybe id . R.updated $
- R.ffor (Input._out_raw name) $ \name ->
- findCategory name (_in_paymentCategories input)
+ R.ffor (Input._out_raw name) findCategory
category <- Select._out_value <$> (Select.view $ Select.In
{ Select._in_label = Msg.get Msg.Payment_Category
- , Select._in_initialValue = _in_category input
+ , Select._in_initialValue = category
, Select._in_value = setCategory
, Select._in_values = R.constDyn categories
- , Select._in_reset = _in_category input <$ reset
+ , Select._in_reset = category <$ reset
, Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input)
, Select._in_validate = confirm
})
@@ -126,12 +124,12 @@ view input = do
c <- cost
d <- date
cat <- category
- return ((_in_mkPayload input)
+ return (mkPayload
<$> ValidationUtil.nelError n
<*> V.Success c
<*> V.Success d
<*> ValidationUtil.nelError cat
- <*> V.Success (_in_frequency input))
+ <*> V.Success frequency)
frequencies =
M.fromList
@@ -142,7 +140,58 @@ view input = do
categories = M.fromList . flip map (_in_categories input) $ \c ->
(_category_id c, _category_name c)
-findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
-findCategory paymentName =
- fmap _paymentCategory_category
- . L.find ((==) (T.toLower paymentName) . _paymentCategory_name)
+ op = _in_operation input
+
+ name =
+ case op of
+ New _ -> ""
+ Clone p -> _payment_name p
+ Edit p -> _payment_name p
+
+ cost =
+ case op of
+ New _ -> ""
+ Clone p -> T.pack . show . _payment_cost $ p
+ Edit p -> T.pack . show . _payment_cost $ p
+
+ date = do
+ currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay
+ return . T.pack . Calendar.showGregorian $
+ case op of
+ New _ -> currentDay
+ Clone p -> currentDay
+ Edit p -> _payment_date p
+
+ category =
+ case op of
+ New _ -> -1
+ Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p)
+ Edit p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p)
+
+ frequency =
+ case op of
+ New f -> f
+ Clone p -> _payment_frequency p
+ Edit p -> _payment_frequency p
+
+ headerLabel =
+ case op of
+ New _ -> Msg.get Msg.Payment_Add
+ Clone _ -> Msg.get Msg.Payment_CloneLong
+ Edit _ -> Msg.get Msg.Payment_EditLong
+
+ ajax =
+ case op of
+ Edit _ -> Ajax.put
+ _ -> Ajax.post
+
+ mkPayload =
+ case op of
+ Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e
+ _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e
+
+ findCategory :: Text -> Maybe CategoryId
+ findCategory paymentName =
+ fmap _paymentCategory_category
+ . L.find ((==) (T.toLower paymentName) . _paymentCategory_name)
+ $ (_in_paymentCategories input)
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 00987a3..c8ca347 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -32,7 +32,7 @@ import qualified Component.Input as Input
import qualified Component.Modal as Modal
import qualified Component.Select as Select
import qualified Util.List as L
-import qualified View.Payment.Add as Add
+import qualified View.Payment.Form as Form
import View.Payment.Init (Init (..))
data In t = In
@@ -120,11 +120,7 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen
Modal.view $ Modal.In
{ Modal._in_show = addPayment
- , Modal._in_content = Add.view $ Add.In
- { Add._in_categories = categories
- , Add._in_paymentCategories = paymentCategories
- , Add._in_frequency = frequency
- }
+ , Modal._in_content = \_ -> return (R.never, R.never) -- TODO
}
searchLine
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
deleted file mode 100644
index 9a1902c..0000000
--- a/client/src/View/Payment/Pages.hs
+++ /dev/null
@@ -1,87 +0,0 @@
-module View.Payment.Pages
- ( view
- , In(..)
- , Out(..)
- ) where
-
-import qualified Data.Text as T
-import Reflex.Dom (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom as R
-
-import qualified Component.Button as Button
-
-import qualified Util.Reflex as ReflexUtil
-import qualified View.Icon as Icon
-
-data In t = In
- { _in_total :: Dynamic t Int
- , _in_perPage :: Int
- , _in_reset :: Event t ()
- }
-
-data Out t = Out
- { _out_currentPage :: Dynamic t Int
- }
-
-view :: forall t m. MonadWidget t m => In t -> m (Out t)
-view input = do
- currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
-
- return $ Out
- { _out_currentPage = currentPage
- }
-
- where
- total = _in_total input
- perPage = _in_perPage input
- reset = _in_reset input
-
-pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int)
-pageButtons total perPage reset = do
- R.divClass "pages" $ do
- rec
- currentPage <- R.holdDyn 1 . R.leftmost $
- [ firstPageClic
- , previousPageClic
- , pageClic
- , nextPageClic
- , lastPageClic
- , 1 <$ reset
- ]
-
- firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar
-
- previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft
-
- pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p ->
- pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p))
-
- nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight
-
- lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar
-
- return currentPage
-
- where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage)
- pageEvent = R.switch . R.current . fmap R.leftmost
- noCurrentPage = R.constDyn Nothing
-
-range :: Int -> Int -> [Int]
-range currentPage maxPage = [start..end]
- where sidePages = 2
- start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2))
- end = min maxPage (start + sidePages * 2)
-
-pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int)
-pageButton currentPage page content = do
- clic <- Button._out_clic <$> (Button.view $ Button.In
- { Button._in_class = do
- cp <- currentPage
- p <- page
- if cp == Just p then "page current" else "page"
- , Button._in_content = content
- , Button._in_waiting = R.never
- , Button._in_tabIndex = Nothing
- , Button._in_submit = False
- })
- return . fmap fst $ R.attach (R.current page) clic
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index e72577f..bf0186f 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -1,181 +1,218 @@
module View.Payment.Payment
- ( init
- , view
+ ( view
, In(..)
) 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 (Currency, Frequency, Income (..),
- Payment (..), PaymentCategory (..),
- PaymentId, SavedPayment (..), User,
- UserId)
-import qualified Common.Util.Text as T
-
-import Loadable (Loadable (..))
+import qualified Data.Maybe as Maybe
+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 (Currency, Frequency, Income (..),
+ Payment (..), PaymentCategory (..),
+ PaymentId, PaymentPage (..),
+ SavedPayment (..), User, UserId)
+import qualified Common.Util.Text as T
+
+import qualified Component.Pages as Pages
+import Loadable (Loadable (..))
import qualified Loadable
-import qualified Util.Ajax as AjaxUtil
-import qualified View.Payment.Header as Header
-import View.Payment.Init (Init (..))
-import qualified View.Payment.Pages as Pages
-import qualified View.Payment.Table as Table
-
-init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
-init = do
- users <- AjaxUtil.getNow "api/users"
- payments <- AjaxUtil.getNow "api/payments"
- incomes <- AjaxUtil.getNow "api/deprecated/incomes"
- categories <- AjaxUtil.getNow "api/categories"
- paymentCategories <- AjaxUtil.getNow "api/paymentCategories"
- return $ do
- us <- users
- ps <- payments
- is <- incomes
- cs <- categories
- pcs <- paymentCategories
- return $ Init <$> us <*> ps <*> is <*> cs <*> pcs
-
+import qualified Util.Ajax as AjaxUtil
+import qualified Util.Reflex as ReflexUtil
+import qualified View.Payment.Header as Header
+import View.Payment.Init (Init (..))
+import qualified View.Payment.Reducer as Reducer
+import qualified View.Payment.Table as Table
data In t = In
{ _in_currentUser :: UserId
+ , _in_users :: [User]
, _in_currency :: Currency
- , _in_init :: Dynamic t (Loadable Init)
}
view :: forall t m. MonadWidget t m => In t -> m ()
view input = do
- R.dyn . R.ffor (_in_init input) . Loadable.view $ \init ->
-
- R.elClass "main" "payment" $ do
- rec
- let addPayment = R.leftmost
- [ Header._out_addPayment header
- , Table._out_addPayment table
- ]
-
- paymentsPerPage = 7
-
- payments <- reducePayments
- (_init_payments init)
- (_savedPayment_payment <$> addPayment)
- (_savedPayment_payment <$> Table._out_editPayment table)
- (Table._out_deletePayment table)
-
- paymentCategories <- reducePaymentCategories
- (_init_paymentCategories init)
- payments
- (_savedPayment_paymentCategory <$> addPayment)
- (_savedPayment_paymentCategory <$> Table._out_editPayment table)
- (Table._out_deletePayment table)
-
- (searchNameEvent, searchName) <-
- debounceSearchName (Header._out_searchName header)
-
- let searchPayments =
- getSearchPayments searchName (Header._out_searchFrequency header) payments
-
- header <- Header.view $ Header.In
- { Header._in_init = init
- , Header._in_currency = _in_currency input
- , Header._in_payments = payments
- , Header._in_searchPayments = searchPayments
- , Header._in_paymentCategories = paymentCategories
- }
-
- table <- Table.view $ Table.In
- { Table._in_init = init
- , Table._in_currency = _in_currency input
- , Table._in_currentUser = _in_currentUser input
- , Table._in_currentPage = Pages._out_currentPage pages
- , Table._in_payments = searchPayments
- , Table._in_perPage = paymentsPerPage
- , Table._in_paymentCategories = paymentCategories
- }
-
- pages <- Pages.view $ Pages.In
- { Pages._in_total = length <$> searchPayments
- , Pages._in_perPage = paymentsPerPage
- , Pages._in_reset = R.leftmost $
- [ () <$ searchNameEvent
- , () <$ Header._out_addPayment header
- ]
- }
-
- pure ()
+
+ categoriesEvent <- (AjaxUtil.getNow "api/categories")
+
+ R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do
+
+ rec
+ payments <- Reducer.reducer $ Reducer.In
+ { Reducer._in_newPage = newPage
+ , Reducer._in_currentPage = currentPage
+ , Reducer._in_addPayment = R.leftmost [headerAddPayment, tableAddPayment]
+ , Reducer._in_editPayment = editPayment
+ , Reducer._in_deletePayment = deletePayment
+ }
+
+ let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
+ eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result
+
+ newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
+ currentPage <- R.holdDyn 1 newPage
+ -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a)
+ let headerAddPayment = R.never
+ tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b)
+ editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
+ deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
+
+ result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) ->
+ flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do
+ table <- Table.view $ Table.In
+ { Table._in_users = _in_users input
+ , Table._in_currentUser = _in_currentUser input
+ , Table._in_categories = categories
+ , Table._in_currency = _in_currency input
+ , Table._in_payments = payments
+ , Table._in_paymentCategories = paymentCategories
+ }
+
+ pages <- Pages.view $ Pages.In
+ { Pages._in_total = R.constDyn count
+ , Pages._in_perPage = Reducer.perPage
+ , Pages._in_page = p
+ }
+
+ return ((), table, pages)
+
+ return ()
return ()
-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)
- ))
+
+-- view :: forall t m. MonadWidget t m => In t -> m ()
+-- view input = do
+-- R.dyn . R.ffor (_in_init input) . Loadable.view $ \init ->
+--
+-- R.elClass "main" "payment" $ do
+-- rec
+-- let addPayment = R.leftmost
+-- -- [ Header._out_addPayment header
+-- [ Table2._out_addPayment table
+-- ]
+--
+-- paymentsPerPage = 7
+--
+-- payments <- reducePayments
+-- (_init_payments init)
+-- (_savedPayment_payment <$> addPayment)
+-- (_savedPayment_payment <$> Table2._out_editPayment table)
+-- (Table2._out_deletePayment table)
+--
+-- paymentCategories <- reducePaymentCategories
+-- (_init_paymentCategories init)
+-- payments
+-- (_savedPayment_paymentCategory <$> addPayment)
+-- (_savedPayment_paymentCategory <$> Table2._out_editPayment table)
+-- (Table2._out_deletePayment table)
+--
+-- -- (searchNameEvent, searchName) <-
+-- -- debounceSearchName (Header._out_searchName header)
+--
+-- -- let searchPayments =
+-- -- getSearchPayments searchName (Header._out_searchFrequency header) payments
+--
+-- -- header <- Header.view $ Header.In
+-- -- { Header._in_init = init
+-- -- , Header._in_currency = _in_currency input
+-- -- , Header._in_payments = payments
+-- -- , Header._in_searchPayments = searchPayments
+-- -- , Header._in_paymentCategories = paymentCategories
+-- -- }
+--
+-- table <- Table2.view $ Table2.In
+-- { Table2._in_init = init
+-- , Table2._in_currency = _in_currency input
+-- , Table2._in_currentUser = _in_currentUser input
+-- , Table2._in_currentPage = Pages2._out_currentPage pages
+-- , Table2._in_payments = payments
+-- , Table2._in_perPage = paymentsPerPage
+-- , Table2._in_paymentCategories = paymentCategories
+-- }
+--
+-- pages <- Pages2.view $ Pages2.In
+-- { Pages2._in_total = length <$> payments
+-- , Pages2._in_perPage = paymentsPerPage
+-- , Pages2._in_reset = R.never
+-- -- [ () <$ searchNameEvent
+-- -- [ () <$ Header._out_addPayment header
+-- -- ]
+-- }
+--
+-- pure ()
+--
+-- return ()
+--
+-- -- 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/Reducer.hs b/client/src/View/Payment/Reducer.hs
new file mode 100644
index 0000000..0c70f8a
--- /dev/null
+++ b/client/src/View/Payment/Reducer.hs
@@ -0,0 +1,66 @@
+module View.Payment.Reducer
+ ( perPage
+ , reducer
+ , In(..)
+ ) 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 (PaymentPage)
+
+import Loadable (Loadable (..))
+import qualified Loadable as Loadable
+import qualified Util.Ajax as AjaxUtil
+
+perPage :: Int
+perPage = 7
+
+data In t a b c = In
+ { _in_newPage :: Event t Int
+ , _in_currentPage :: Dynamic t Int
+ , _in_addPayment :: Event t a
+ , _in_editPayment :: Event t b
+ , _in_deletePayment :: Event t c
+ }
+
+data Action
+ = LoadPage Int
+ | GetResult (Either Text PaymentPage)
+
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage))
+reducer input = do
+
+ postBuild <- R.getPostBuild
+
+ let loadPage =
+ R.leftmost
+ [ 1 <$ postBuild
+ , _in_newPage input
+ , 1 <$ _in_addPayment input
+ , R.tag (R.current $ _in_currentPage input) (_in_editPayment input)
+ , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input)
+ ]
+
+ getResult <- AjaxUtil.get $ fmap pageUrl loadPage
+
+ R.foldDyn
+ (\action _ -> case action of
+ LoadPage _ -> Loading
+ GetResult (Left err) -> Error err
+ GetResult (Right payments) -> Loaded payments
+ )
+ Loading
+ (R.leftmost
+ [ LoadPage <$> loadPage
+ , GetResult <$> getResult
+ ])
+
+ where
+ pageUrl p =
+ "api/payments?page="
+ <> (T.pack . show $ p)
+ <> "&perPage="
+ <> (T.pack . show $ perPage)
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 0793836..dde5168 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -4,209 +4,146 @@ module View.Payment.Table
, Out(..)
) where
-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 Prelude hiding (init)
-import Reflex.Dom (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom as R
-
-import Common.Model (Category (..), Currency,
- Frequency (Punctual), Payment (..),
- PaymentCategory (..), SavedPayment,
- User (..), UserId)
-import qualified Common.Model as CM
-import qualified Common.Msg as Msg
-import qualified Common.View.Format as Format
-import qualified Component.Button as Button
-import qualified Component.Modal as Modal
-import qualified View.Payment.Clone as Clone
-import qualified View.Payment.Delete as Delete
-import qualified View.Payment.Edit as Edit
-import View.Payment.Init (Init (..))
-
-import qualified Util.Reflex as ReflexUtil
-import qualified View.Icon as Icon
+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 Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Category (..), Currency, Payment (..),
+ PaymentCategory (..), SavedPayment,
+ User (..), UserId)
+import qualified Common.Model as CM
+import qualified Common.Msg as Msg
+import qualified Common.View.Format as Format
+
+import qualified Component.ConfirmDialog as ConfirmDialog
+import qualified Component.Table as Table
+import qualified Util.Ajax as Ajax
+import qualified Util.Either as EitherUtil
+import qualified View.Payment.Form as Form
data In t = In
- { _in_init :: Init
- , _in_currency :: Currency
+ { _in_users :: [User]
, _in_currentUser :: UserId
- , _in_currentPage :: Dynamic t Int
- , _in_payments :: Dynamic t [Payment]
- , _in_perPage :: Int
- , _in_paymentCategories :: Dynamic t [PaymentCategory]
, _in_categories :: [Category]
+ , _in_currency :: Currency
+ , _in_payments :: [Payment]
+ , _in_paymentCategories :: [PaymentCategory]
}
data Out t = Out
- { _out_addPayment :: Event t SavedPayment
- , _out_editPayment :: Event t SavedPayment
- , _out_deletePayment :: Event t Payment
+ { _out_add :: Event t SavedPayment
+ , _out_edit :: Event t SavedPayment
+ , _out_delete :: Event t Payment
}
view :: forall t m. MonadWidget t m => In t -> m (Out t)
view input = do
- R.divClass "table" $ do
-
- (addPayment, editPayment, deletePayment) <- 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
- R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User
- R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category
- R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date
- R.divClass "cell" $ R.blank
- R.divClass "cell" $ R.blank
- R.divClass "cell" $ R.blank
-
- result <-
- (R.simpleList paymentRange (paymentRow init currency currentUser paymentCategories))
-
- return $
- ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
- , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result
- , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result
- )
-
- ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
- R.text $ Msg.get Msg.Payment_Empty
-
- return $ Out
- { _out_addPayment = addPayment
- , _out_editPayment = editPayment
- , _out_deletePayment = deletePayment
- }
-
- where
- init = _in_init input
- currency = _in_currency input
- currentUser = _in_currentUser input
- currentPage = _in_currentPage input
- payments = _in_payments input
- paymentRange = getPaymentRange (_in_perPage input) <$> payments <*> currentPage
- paymentCategories = _in_paymentCategories input
-
-getPaymentRange :: Int -> [Payment] -> Int -> [Payment]
-getPaymentRange perPage payments currentPage =
- take perPage
- . drop ((currentPage - 1) * perPage)
- . reverse
- . L.sortOn _payment_date
- $ payments
-
-paymentRow
- :: forall t m. MonadWidget t m
- => Init
- -> Currency
- -> UserId
- -> Dynamic t [PaymentCategory]
- -> Dynamic t Payment
- -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment)
-paymentRow init currency currentUser 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 currency . _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
- _ -> ""
-
- let category = do
- 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 $ R.ffor category $ \case
- Just c -> _category_name c
- _ -> ""
-
- 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
-
- let categoryId = (Maybe.fromMaybe (-1) . fmap _category_id) <$> category
-
- clonePayment <-
- R.divClass "cell button" $
- Button._out_clic <$> (Button.view $
- Button.defaultIn Icon.clone)
-
- paymentCloned <-
- Modal.view $ Modal.In
- { Modal._in_show = clonePayment
- , Modal._in_content =
- Clone.view $ Clone.In
- { Clone._in_show = clonePayment
- , Clone._in_categories = _init_categories init
- , Clone._in_paymentCategories = paymentCategories
- , Clone._in_payment = payment
- , Clone._in_category = categoryId
- }
- }
- let isFromCurrentUser =
- R.ffor
- payment
- (\p -> _payment_user p == currentUser)
-
- editPayment <-
- R.divClass "cell button" $
- ReflexUtil.divVisibleIf isFromCurrentUser $
- Button._out_clic <$> (Button.view $
- Button.defaultIn Icon.edit)
-
- paymentEdited <-
- Modal.view $ Modal.In
- { Modal._in_show = editPayment
- , Modal._in_content =
- Edit.view $ Edit.In
- { Edit._in_show = editPayment
- , Edit._in_categories = _init_categories init
- , Edit._in_paymentCategories = paymentCategories
- , Edit._in_payment = payment
- , Edit._in_category = categoryId
- }
+ table <- Table.view $ Table.In
+ { Table._in_headerLabel = headerLabel
+ , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input
+ , Table._in_cell =
+ cell
+ (_in_users input)
+ (_in_categories input)
+ (_in_paymentCategories input)
+ (_in_currency input)
+ , Table._in_cloneModal = \payment ->
+ Form.view $ Form.In
+ { Form._in_categories = _in_categories input
+ , Form._in_paymentCategories = _in_paymentCategories input
+ , Form._in_operation = Form.Clone payment
}
-
- deletePayment <-
- R.divClass "cell button" $
- ReflexUtil.divVisibleIf isFromCurrentUser $
- Button._out_clic <$> (Button.view $
- (Button.defaultIn Icon.delete)
- { Button._in_class = R.constDyn "deletePayment"
- })
-
- paymentDeleted <-
- Modal.view $ Modal.In
- { Modal._in_show = deletePayment
- , Modal._in_content =
- Delete.view $ Delete.In
- { Delete._in_payment = payment
- }
+ , Table._in_editModal = \payment ->
+ Form.view $ Form.In
+ { Form._in_categories = _in_categories input
+ , Form._in_paymentCategories = _in_paymentCategories input
+ , Form._in_operation = Form.Edit payment
}
-
- return $ (paymentCloned, paymentEdited, paymentDeleted)
+ , Table._in_deleteModal = \payment ->
+ ConfirmDialog.view $ ConfirmDialog.In
+ { ConfirmDialog._in_header = Msg.get Msg.Payment_DeleteConfirm
+ , ConfirmDialog._in_confirm = \e -> do
+ res <- Ajax.delete
+ (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment])
+ e
+ return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res
+ }
+ , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user
+ }
+
+ return $ Out
+ { _out_add = Table._out_add table
+ , _out_edit = Table._out_edit table
+ , _out_delete = Table._out_delete table
+ }
+
+data Header
+ = NameHeader
+ | CostHeader
+ | UserHeader
+ | CategoryHeader
+ | DateHeader
+ deriving (Eq, Show, Bounded, Enum)
+
+headerLabel :: Header -> Text
+headerLabel NameHeader = Msg.get Msg.Payment_Name
+headerLabel CostHeader = Msg.get Msg.Payment_Cost
+headerLabel UserHeader = Msg.get Msg.Payment_User
+headerLabel CategoryHeader = Msg.get Msg.Payment_Category
+headerLabel DateHeader = Msg.get Msg.Payment_Date
+
+cell
+ :: forall t m. MonadWidget t m
+ => [User]
+ -> [Category]
+ -> [PaymentCategory]
+ -> Currency
+ -> Header
+ -> Payment
+ -> m ()
+cell users categories paymentCategories currency header payment =
+ case header of
+ NameHeader ->
+ R.text $ _payment_name payment
+
+ CostHeader ->
+ R.text . Format.price currency . _payment_cost $ payment
+
+ UserHeader ->
+ R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_payment_user payment) users
+
+ CategoryHeader ->
+ let
+ category =
+ findCategory categories paymentCategories (_payment_name payment)
+
+ attrs =
+ case category of
+ Just c ->
+ M.fromList
+ [ ("class", "tag")
+ , ("style", T.concat [ "background-color: ", _category_color c ])
+ ]
+
+ Nothing ->
+ M.singleton "display" "none"
+ in
+ R.elAttr "span" attrs $
+ R.text $
+ Maybe.fromMaybe "" (_category_name <$> category)
+
+ DateHeader ->
+ do
+ R.elClass "span" "shortDate" $
+ R.text . Format.shortDay . _payment_date $ payment
+
+ R.elClass "span" "longDate" $
+ R.text . Format.longDay . _payment_date $ payment
findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
findCategory categories paymentCategories paymentName = do
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:56:17 +0000