aboutsummaryrefslogtreecommitdiff
path: root/client
diff options
context:
space:
mode:
Diffstat (limited to 'client')
-rw-r--r--client/client.cabal5
-rw-r--r--client/src/Component/Modal.hs63
-rw-r--r--client/src/Util/Reflex.hs (renamed from client/src/Util/Dom.hs)33
-rw-r--r--client/src/View/Payment.hs14
-rw-r--r--client/src/View/Payment/Add.hs187
-rw-r--r--client/src/View/Payment/Clone.hs60
-rw-r--r--client/src/View/Payment/Delete.hs57
-rw-r--r--client/src/View/Payment/Edit.hs55
-rw-r--r--client/src/View/Payment/Form.hs165
-rw-r--r--client/src/View/Payment/Header.hs39
-rw-r--r--client/src/View/Payment/Pages.hs14
-rw-r--r--client/src/View/Payment/Table.hs109
12 files changed, 516 insertions, 285 deletions
diff --git a/client/client.cabal b/client/client.cabal
index ce3c059..5fc20ae 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -44,16 +44,19 @@ Executable client
Component.Select
Icon
Util.Ajax
- Util.Dom
Util.Either
Util.List
+ Util.Reflex
Util.Validation
Util.WaitFor
View.App
View.Header
View.Payment
View.Payment.Add
+ View.Payment.Clone
View.Payment.Delete
+ View.Payment.Edit
+ View.Payment.Form
View.Payment.Header
View.Payment.Pages
View.Payment.Table
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index fac417e..96c2679 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -1,7 +1,7 @@
module Component.Modal
- ( ModalIn(..)
- , ModalOut(..)
- , modal
+ ( Input(..)
+ , Content
+ , view
) where
import Control.Monad (void)
@@ -17,29 +17,26 @@ import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import qualified Reflex.Dom.Class as R
-import qualified Util.Dom as Dom
+import qualified Util.Reflex as ReflexUtil
-data ModalIn t m a = ModalIn
- { _modalIn_show :: Event t ()
- , _modalIn_hide :: Event t ()
- , _modalIn_content :: m a
- }
+-- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent)
+type Content t m a = Event t () -> m (Event t (), Event t a)
-data ModalOut t a = ModalOut
- { _modalOut_content :: a
- , _modalOut_hide :: Event t ()
+data Input t m a = Input
+ { _input_show :: Event t ()
+ , _input_content :: Content t m a
}
-modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a)
-modal modalIn = do
+view :: forall t m a. MonadWidget t m => Input t m a -> m (Event t a)
+view input = do
rec
- let show = Show <$ (_modalIn_show modalIn)
+ let show = Show <$ (_input_show input)
startHiding =
R.attachWithMaybe
(\a _ -> if a then Just StartHiding else Nothing)
(R.current canBeHidden)
- (R.leftmost [ _modalIn_hide modalIn, curtainClick ])
+ (R.leftmost [ hide, curtainClick ])
canBeHidden <-
R.holdDyn True $ R.leftmost
@@ -56,18 +53,25 @@ modal modalIn = do
modalClass <-
R.holdDyn "" (fmap getModalClass action)
- (elem, (curtainClick, content)) <-
- R.buildElement "div" (fmap getAttributes modalClass) $ do
- (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank
- content <- R.divClass "g-Modal__Content" $ _modalIn_content modalIn
- return (R.domEvent R.Click curtain, content)
+ (elem, dyn) <-
+ R.buildElement "div" (getAttributes <$> modalClass) $
+ ReflexUtil.visibleIfEvent
+ (isVisible <$> action)
+ (R.blank >> return (R.never, R.never, R.never))
+ (do
+ (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank
+ let curtainClick = R.domEvent R.Click curtain
+ (hide, content) <- R.divClass "g-Modal__Content" (_input_content input curtainClick)
+ return (curtainClick, hide, content))
+
- performShowEffects action elem
+ performShowEffects action elem
- return $ ModalOut
- { _modalOut_content = content
- , _modalOut_hide = curtainClick
- }
+ let curtainClick = R.switchDyn $ (\(a, _, _) -> a) <$> dyn
+ let hide = R.switchDyn $ (\(_, b, _) -> b) <$> dyn
+ let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn
+
+ return content
getAttributes :: Text -> LM.Map Text Text
getAttributes modalClass =
@@ -80,7 +84,7 @@ performShowEffects
-> Element.Element
-> m ()
performShowEffects showEvent elem = do
- body <- Dom.getBody
+ body <- ReflexUtil.getBody
let showEffects =
flip fmap showEvent (\case
@@ -105,3 +109,8 @@ getModalClass :: Action -> Text
getModalClass Show = "g-Modal--Show"
getModalClass StartHiding = "g-Modal--Hiding"
getModalClass _ = ""
+
+isVisible :: Action -> Bool
+isVisible Show = True
+isVisible StartHiding = True
+isVisible EndHiding = False
diff --git a/client/src/Util/Dom.hs b/client/src/Util/Reflex.hs
index 55b8521..c14feeb 100644
--- a/client/src/Util/Dom.hs
+++ b/client/src/Util/Reflex.hs
@@ -1,8 +1,9 @@
-module Util.Dom
- ( divIfDyn
- , divIfEvent
+module Util.Reflex
+ ( visibleIfDyn
+ , visibleIfEvent
, divVisibleIf
, divClassVisibleIf
+ , flatten
, getBody
) where
@@ -15,17 +16,18 @@ import GHCJS.DOM.Types (Element)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
-divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a)
-divIfDyn cond = divIfEvent (R.updated cond)
+visibleIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Event t a)
+visibleIfDyn cond empty content =
+ R.dyn $ R.ffor cond $ \case
+ True -> content
+ False -> empty
-divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
-divIfEvent cond empty content =
- R.widgetHold empty (flip fmap cond (\show ->
- if show
- then
- content
- else
- empty))
+visibleIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
+visibleIfEvent cond empty content =
+ R.widgetHold empty $
+ R.ffor cond $ \case
+ True -> content
+ False -> empty
divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
divVisibleIf cond content = divClassVisibleIf cond "" content
@@ -37,6 +39,11 @@ divClassVisibleIf cond className content =
(fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
content
+flatten :: forall t m a. MonadWidget t m => Event t (Event t a) -> m (Event t a)
+flatten e = do
+ dyn <- R.holdDyn R.never e
+ return $ R.switchDyn dyn
+
getBody :: forall t m. MonadWidget t m => m Element
getBody = do
document <- Dom.currentDocumentUnchecked
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index f363b06..ab83447 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -11,9 +11,9 @@ import Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
-import Common.Model (CreatedPayment (..), Frequency, Init (..),
- Payment (..), PaymentCategory (..),
- PaymentId)
+import Common.Model (Frequency, Init (..), Payment (..),
+ PaymentCategory (..), PaymentId,
+ SavedPayment (..))
import qualified Common.Util.Text as T
import View.Payment.Header (HeaderIn (..), HeaderOut (..))
import qualified View.Payment.Header as Header
@@ -36,15 +36,19 @@ widget paymentIn = do
rec
let init = _paymentIn_init paymentIn
paymentsPerPage = 7
+ savedPayments = R.leftmost
+ [ _headerOut_addPayment header
+ , _tableOut_addPayment table
+ ]
payments <- getPayments
(_init_payments init)
- (_createdPayment_payment <$> _headerOut_addPayment header)
+ (_savedPayment_payment <$> savedPayments)
(_tableOut_deletePayment table)
paymentCategories <- getPaymentCategories
(_init_paymentCategories init)
- (_createdPayment_paymentCategory <$> _headerOut_addPayment header)
+ (_savedPayment_paymentCategory <$> savedPayments)
payments
(_tableOut_deletePayment table)
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 69e29a7..88806bc 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -1,161 +1,54 @@
module View.Payment.Add
( view
- , AddIn(..)
- , AddOut(..)
+ , Input(..)
) 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 (Dynamic, Event, MonadWidget, Reflex)
+import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
-import qualified Text.Read as T
-import Common.Model (Category (..), CategoryId,
- CreatePayment (..),
- CreatedPayment (..), Frequency (..),
- Payment (..), PaymentCategory (..))
+import Common.Model (Category (..), CreatePayment (..),
+ Frequency (..), Payment (..),
+ PaymentCategory (..),
+ SavedPayment (..))
import qualified Common.Msg as Msg
-import qualified Common.Util.Time as Time
+import qualified Common.Util.Time as TimeUtil
import qualified Common.Validation.Payment as PaymentValidation
-import Component (ButtonIn (..), InputIn (..),
- InputOut (..), SelectIn (..),
- SelectOut (..))
-import qualified Component as Component
-import qualified Util.Ajax as Ajax
-import qualified Util.Either as EitherUtil
-import qualified Util.Validation as ValidationUtil
-import qualified Util.WaitFor as WaitFor
-
-data AddIn t = AddIn
- { _addIn_categories :: [Category]
- , _addIn_paymentCategories :: Dynamic t [PaymentCategory]
- , _addIn_frequency :: Dynamic t Frequency
- , _addIn_cancel :: Event t ()
- }
-
-data AddOut t = AddOut
- { _addOut_cancel :: Event t ()
- , _addOut_addPayment :: Event t CreatedPayment
- , _addOut_addPaymentCategory :: Event t PaymentCategory
+import qualified Component.Modal as Modal
+import qualified Util.Reflex as ReflexUtil
+import qualified View.Payment.Form as Form
+
+data Input t = Input
+ { _input_categories :: [Category]
+ , _input_paymentCategories :: Dynamic t [PaymentCategory]
+ , _input_frequency :: Dynamic t Frequency
}
-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
- rec
- let reset = R.leftmost
- [ "" <$ cancel
- , "" <$ addPayment
- , "" <$ _addIn_cancel addIn
- ]
-
- name <- Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Payment_Name
- , _inputIn_validation = PaymentValidation.name
- })
- reset
- confirm
-
- cost <- _inputOut_value <$> (Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Payment_Cost
- , _inputIn_validation = PaymentValidation.cost
- })
- reset
- confirm)
-
- now <- liftIO Time.getCurrentTime
-
- currentDay <- do
- d <- liftIO $ Time.timeToDay now
- return . T.pack . Calendar.showGregorian $ d
-
- date <- _inputOut_value <$> (Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Payment_Date
- , _inputIn_initialValue = currentDay
- , _inputIn_inputType = "date"
- , _inputIn_hasResetButton = False
- , _inputIn_validation = PaymentValidation.date
- })
- (currentDay <$ reset)
- confirm)
-
- 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
- , _selectIn_validate = confirm
- })
-
- let payment = do
- n <- _inputOut_value name
- c <- cost
- d <- date
- cat <- category
- f <- _addIn_frequency addIn
- return (CreatePayment
- <$> ValidationUtil.nelError n
- <*> ValidationUtil.nelError c
- <*> ValidationUtil.nelError d
- <*> ValidationUtil.nelError cat
- <*> V.Success f)
-
- (addPayment, cancel, confirm) <- R.divClass "buttons" $ do
- rec
- cancel <- Component._buttonOut_clic <$> (Component.button $
- (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
- { _buttonIn_class = R.constDyn "undo" })
-
- confirm <- Component._buttonOut_clic <$> (Component.button $
- (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
- { _buttonIn_class = R.constDyn "confirm"
- , _buttonIn_waiting = waiting
- , _buttonIn_submit = True
- })
-
- (addPayment, waiting) <- WaitFor.waitFor
- (Ajax.postJson "/payment")
- (ValidationUtil.fireValidation payment confirm)
-
- return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
-
- return AddOut
- { _addOut_cancel = cancel
- , _addOut_addPayment = addPayment
- }
-
- where
- frequencies = M.fromList
- [ (Punctual, Msg.get Msg.Payment_PunctualMale)
- , (Monthly, Msg.get Msg.Payment_MonthlyMale)
- ]
-
- 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 ((==) (T.toLower paymentName) . _paymentCategory_name)
+view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment
+view input cancel = do
+
+ currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
+
+ formOutput <- R.dyn $ do
+ paymentCategories <- _input_paymentCategories input
+ frequency <- _input_frequency input
+ return $ Form.view $ Form.Input
+ { Form._input_cancel = cancel
+ , Form._input_headerLabel = Msg.get Msg.Payment_Add
+ , Form._input_categories = _input_categories input
+ , Form._input_paymentCategories = paymentCategories
+ , Form._input_name = ""
+ , Form._input_cost = ""
+ , Form._input_date = currentDay
+ , Form._input_category = -1
+ , Form._input_frequency = frequency
+ , Form._input_mkPayload = CreatePayment
+ }
+
+ 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
new file mode 100644
index 0000000..5624f6c
--- /dev/null
+++ b/client/src/View/Payment/Clone.hs
@@ -0,0 +1,60 @@
+module View.Payment.Clone
+ ( Input(..)
+ , 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,
+ CreatePayment (..), 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.Modal as Modal
+import qualified Util.Reflex as ReflexUtil
+import qualified View.Payment.Form as Form
+
+data Input t = Input
+ { _input_show :: Event t ()
+ , _input_categories :: [Category]
+ , _input_paymentCategories :: Dynamic t [PaymentCategory]
+ , _input_payment :: Dynamic t Payment
+ , _input_category :: Dynamic t CategoryId
+ }
+
+view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment
+view input cancel = do
+
+ currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
+
+ formOutput <- R.dyn $ do
+ paymentCategories <- _input_paymentCategories input
+ payment <- _input_payment input
+ category <- _input_category input
+ return . Form.view $ Form.Input
+ { Form._input_cancel = cancel
+ , Form._input_headerLabel = Msg.get Msg.Payment_CloneLong
+ , Form._input_categories = _input_categories input
+ , Form._input_paymentCategories = paymentCategories
+ , Form._input_name = _payment_name payment
+ , Form._input_cost = T.pack . show . _payment_cost $ payment
+ , Form._input_date = currentDay
+ , Form._input_category = category
+ , Form._input_frequency = _payment_frequency payment
+ , Form._input_mkPayload = CreatePayment
+ }
+
+ hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
+ clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput)
+
+ return $
+ ( hide
+ , clonePayment
+ )
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 65ce660..e7e319e 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -1,39 +1,34 @@
module View.Payment.Delete
- ( view
- , DeleteIn(..)
- , DeleteOut(..)
+ ( Input(..)
+ , 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 Component (ButtonIn (..), ButtonOut (..))
-import qualified Component as Component
-import qualified Util.Ajax as Ajax
-import qualified Util.Either as EitherUtil
-import qualified Util.WaitFor as WaitFor
-
-data DeleteIn t = DeleteIn
- { _deleteIn_payment :: Dynamic t Payment
- }
-
-data DeleteOut t = DeleteOut
- { _deleteOut_cancel :: Event t ()
- , _deleteOut_validate :: Event t Payment
+import Data.Text (Text)
+import qualified Data.Text as T
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Payment (..))
+import qualified Common.Msg as Msg
+import Component (ButtonIn (..), ButtonOut (..))
+import qualified Component as Component
+import qualified Component.Modal as Modal
+import qualified Util.Ajax as Ajax
+import qualified Util.Either as EitherUtil
+import qualified Util.WaitFor as WaitFor
+
+data Input t = Input
+ { _input_payment :: Dynamic t Payment
}
-view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t)
-view deleteIn =
+view :: forall t m. MonadWidget t m => (Input 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
- (deletedPayment, cancel) <- R.divClass "buttons" $ do
+ (confirm, cancel) <- R.divClass "buttons" $ do
cancel <- Component._buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
@@ -48,7 +43,7 @@ view deleteIn =
})
let url =
- R.ffor (_deleteIn_payment deleteIn) (\id ->
+ R.ffor (_input_payment input) (\id ->
T.concat ["/payment/", T.pack . show $ _payment_id id]
)
@@ -58,7 +53,7 @@ view deleteIn =
return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
- return DeleteOut
- { _deleteOut_cancel = cancel
- , _deleteOut_validate = R.tag (R.current $ _deleteIn_payment deleteIn) deletedPayment
- }
+ return $
+ ( R.leftmost [ cancel, () <$ confirm ]
+ , R.tag (R.current $ _input_payment input) confirm
+ )
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
new file mode 100644
index 0000000..5020e57
--- /dev/null
+++ b/client/src/View/Payment/Edit.hs
@@ -0,0 +1,55 @@
+module View.Payment.Edit
+ ( Input(..)
+ , 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,
+ EditPayment (..), Frequency (..),
+ Payment (..), PaymentCategory (..),
+ SavedPayment (..))
+import qualified Common.Msg as Msg
+import qualified Common.Validation.Payment as PaymentValidation
+import qualified Component.Modal as Modal
+import qualified Util.Reflex as ReflexUtil
+import qualified View.Payment.Form as Form
+
+data Input t = Input
+ { _input_show :: Event t ()
+ , _input_categories :: [Category]
+ , _input_paymentCategories :: Dynamic t [PaymentCategory]
+ , _input_payment :: Dynamic t Payment
+ , _input_category :: Dynamic t CategoryId
+ }
+
+view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment
+view input cancel = do
+
+ formOutput <- R.dyn $ do
+ paymentCategories <- _input_paymentCategories input
+ payment <- _input_payment input
+ category <- _input_category input
+ return . Form.view $ Form.Input
+ { Form._input_cancel = cancel
+ , Form._input_headerLabel = Msg.get Msg.Payment_EditLong
+ , Form._input_categories = _input_categories input
+ , Form._input_paymentCategories = paymentCategories
+ , Form._input_name = _payment_name payment
+ , Form._input_cost = T.pack . show . _payment_cost $ payment
+ , Form._input_date = _payment_date payment
+ , Form._input_category = category
+ , Form._input_frequency = _payment_frequency payment
+ , Form._input_mkPayload = EditPayment (_payment_id payment)
+ }
+
+ 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
new file mode 100644
index 0000000..ba54957
--- /dev/null
+++ b/client/src/View/Payment/Form.hs
@@ -0,0 +1,165 @@
+module View.Payment.Form
+ ( view
+ , Input(..)
+ , Output(..)
+ ) where
+
+import Control.Monad (join)
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson (ToJSON)
+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 Data.Time.Calendar (Day)
+import qualified Data.Time.Calendar as Calendar
+import qualified Data.Validation as V
+import Reflex.Dom (Dynamic, Event, MonadHold,
+ MonadWidget, Reflex)
+import qualified Reflex.Dom as R
+import qualified Text.Read as T
+
+import Common.Model (Category (..), CategoryId,
+ Frequency (..), Payment (..),
+ PaymentCategory (..),
+ SavedPayment (..))
+import qualified Common.Msg as Msg
+import qualified Common.Validation.Payment as PaymentValidation
+import Component (ButtonIn (..), InputIn (..),
+ InputOut (..), SelectIn (..),
+ SelectOut (..))
+import qualified Component as Component
+import qualified Util.Ajax as Ajax
+import qualified Util.Either as EitherUtil
+import qualified Util.Validation as ValidationUtil
+import qualified Util.WaitFor as WaitFor
+
+data Input t p = Input
+ { _input_cancel :: Event t ()
+ , _input_headerLabel :: Text
+ , _input_categories :: [Category]
+ , _input_paymentCategories :: [PaymentCategory]
+ , _input_name :: Text
+ , _input_cost :: Text
+ , _input_date :: Day
+ , _input_category :: CategoryId
+ , _input_frequency :: Frequency
+ , _input_mkPayload :: Text -> Int -> Day -> CategoryId -> Frequency -> p
+ }
+
+data Output t = Output
+ { _output_hide :: Event t ()
+ , _output_addPayment :: Event t SavedPayment
+ }
+
+view :: forall t m p. (MonadWidget t m, ToJSON p) => Input t p -> m (Output t)
+view input = do
+ R.divClass "form" $ do
+ R.divClass "formHeader" $
+ R.text (_input_headerLabel input)
+
+ R.divClass "formContent" $ do
+ rec
+ let reset = R.leftmost
+ [ "" <$ cancel
+ , "" <$ addPayment
+ , "" <$ _input_cancel input
+ ]
+
+ name <- Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Payment_Name
+ , _inputIn_initialValue = _input_name input
+ , _inputIn_validation = PaymentValidation.name
+ })
+ (_input_name input <$ reset)
+ confirm
+
+ cost <- _inputOut_value <$> (Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Payment_Cost
+ , _inputIn_initialValue = _input_cost input
+ , _inputIn_validation = PaymentValidation.cost
+ })
+ (_input_cost input <$ reset)
+ confirm)
+
+ let initialDate = T.pack . Calendar.showGregorian . _input_date $ input
+
+ date <- _inputOut_value <$> (Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Payment_Date
+ , _inputIn_initialValue = initialDate
+ , _inputIn_inputType = "date"
+ , _inputIn_hasResetButton = False
+ , _inputIn_validation = PaymentValidation.date
+ })
+ (initialDate <$ reset)
+ confirm)
+
+ let setCategory =
+ R.fmapMaybe id . R.updated $
+ R.ffor (_inputOut_raw name) $ \name ->
+ findCategory name (_input_paymentCategories input)
+
+ category <- _selectOut_value <$> (Component.select $ SelectIn
+ { _selectIn_label = Msg.get Msg.Payment_Category
+ , _selectIn_initialValue = _input_category input
+ , _selectIn_value = setCategory
+ , _selectIn_values = R.constDyn categories
+ , _selectIn_reset = _input_category input <$ reset
+ , _selectIn_isValid = (/= -1)
+ , _selectIn_validate = confirm
+ })
+
+ let payment = do
+ n <- _inputOut_value name
+ c <- cost
+ d <- date
+ cat <- category
+ return ((_input_mkPayload input)
+ <$> ValidationUtil.nelError n
+ <*> ValidationUtil.nelError c
+ <*> ValidationUtil.nelError d
+ <*> ValidationUtil.nelError cat
+ <*> V.Success (_input_frequency input))
+
+ (addPayment, cancel, confirm) <- R.divClass "buttons" $ do
+ rec
+ cancel <- Component._buttonOut_clic <$> (Component.button $
+ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+ { _buttonIn_class = R.constDyn "undo" })
+
+ confirm <- Component._buttonOut_clic <$> (Component.button $
+ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+ { _buttonIn_class = R.constDyn "confirm"
+ , _buttonIn_waiting = waiting
+ , _buttonIn_submit = True
+ })
+
+ (addPayment, waiting) <- WaitFor.waitFor
+ (Ajax.postJson "/payment")
+ (ValidationUtil.fireValidation payment confirm)
+
+ return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
+
+ return Output
+ { _output_hide = R.leftmost [ cancel, () <$ addPayment ]
+ , _output_addPayment = addPayment
+ }
+
+ where
+ frequencies = M.fromList
+ [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+ , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+ ]
+
+ categories = M.fromList . flip map (_input_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)
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 1bdee8d..7281195 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -17,10 +17,10 @@ import Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
-import Common.Model (Category, CreatedPayment (..),
- Currency, ExceedingPayer (..),
- Frequency (..), Income (..), Init (..),
- Payment (..), PaymentCategory,
+import Common.Model (Category, Currency,
+ ExceedingPayer (..), Frequency (..),
+ Income (..), Init (..), Payment (..),
+ PaymentCategory, SavedPayment (..),
User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
@@ -28,11 +28,10 @@ import qualified Common.View.Format as Format
import Component (ButtonIn (..), ButtonOut (..),
InputIn (..), InputOut (..),
- ModalIn (..), ModalOut (..),
SelectIn (..), SelectOut (..))
import qualified Component as Component
+import qualified Component.Modal as Modal
import qualified Util.List as L
-import View.Payment.Add (AddIn (..), AddOut (..))
import qualified View.Payment.Add as Add
data HeaderIn t = HeaderIn
@@ -45,7 +44,7 @@ data HeaderIn t = HeaderIn
data HeaderOut t = HeaderOut
{ _headerOut_searchName :: Dynamic t Text
, _headerOut_searchFrequency :: Dynamic t Frequency
- , _headerOut_addPayment :: Event t CreatedPayment
+ , _headerOut_addPayment :: Event t SavedPayment
}
widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
@@ -90,7 +89,7 @@ payerAndAdd
-> Dynamic t [PaymentCategory]
-> Currency
-> Dynamic t Frequency
- -> m (Event t CreatedPayment)
+ -> m (Event t SavedPayment)
payerAndAdd incomes payments users categories paymentCategories currency frequency = do
time <- liftIO Time.getCurrentTime
R.divClass "payerAndAdd" $ do
@@ -119,22 +118,14 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen
, _buttonIn_submit = False
})
- rec
- modalOut <- Component.modal $ ModalIn
- { _modalIn_show = addPaymentClic
- , _modalIn_hide = R.leftmost $
- [ _addOut_cancel addOut
- , fmap (const ()) . _addOut_addPayment $ addOut
- ]
- , _modalIn_content = Add.view $ AddIn
- { _addIn_categories = categories
- , _addIn_paymentCategories = paymentCategories
- , _addIn_frequency = frequency
- , _addIn_cancel = _modalOut_hide modalOut
- }
- }
- let addOut = _modalOut_content modalOut
- return (_addOut_addPayment addOut)
+ Modal.view $ Modal.Input
+ { Modal._input_show = addPaymentClic
+ , Modal._input_content = Add.view $ Add.Input
+ { Add._input_categories = categories
+ , Add._input_paymentCategories = paymentCategories
+ , Add._input_frequency = frequency
+ }
+ }
searchLine
:: forall t m. MonadWidget t m
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index cbe7b50..9247143 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -4,15 +4,15 @@ module View.Payment.Pages
, PagesOut(..)
) where
-import qualified Data.Text as T
-import Reflex.Dom (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom as R
+import qualified Data.Text as T
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
-import Component (ButtonIn (..), ButtonOut (..))
-import qualified Component as Component
+import Component (ButtonIn (..), ButtonOut (..))
+import qualified Component as Component
import qualified Icon
-import qualified Util.Dom as Dom
+import qualified Util.Reflex as ReflexUtil
data PagesIn t = PagesIn
{ _pagesIn_total :: Dynamic t Int
@@ -26,7 +26,7 @@ data PagesOut t = PagesOut
widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t)
widget pagesIn = do
- currentPage <- Dom.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
+ currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
return $ PagesOut
{ _pagesOut_currentPage = currentPage
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index b09f30f..f2b8870 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -6,25 +6,32 @@ module View.Payment.Table
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 (..), Init (..), Payment (..),
- PaymentCategory (..), User (..))
+import Common.Model (Category (..), Frequency (Punctual),
+ Init (..), Payment (..),
+ PaymentCategory (..), SavedPayment,
+ User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
-import Component (ButtonIn (..), ButtonOut (..),
- ModalIn (..), ModalOut (..))
+import Component (ButtonIn (..), ButtonOut (..))
import qualified Component as Component
-import View.Payment.Delete (DeleteIn (..), DeleteOut (..))
+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 qualified Icon
-import qualified Util.Dom as DomUtil
+import qualified Util.Reflex as ReflexUtil
+
+-- TODO: remove
+import Debug.Trace (trace)
data TableIn t = TableIn
{ _tableIn_init :: Init
@@ -32,17 +39,19 @@ data TableIn t = TableIn
, _tableIn_payments :: Dynamic t [Payment]
, _tableIn_perPage :: Int
, _tableIn_paymentCategories :: Dynamic t [PaymentCategory]
+ , _tableIn_categories :: [Category]
}
data TableOut t = TableOut
- { _tableOut_deletePayment :: Event t Payment
+ { _tableOut_addPayment :: Event t SavedPayment
+ , _tableOut_deletePayment :: Event t Payment
}
widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
widget tableIn = do
R.divClass "table" $ do
- deletePayment <- R.divClass "lines" $ do
+ (addPayment, 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
@@ -52,14 +61,21 @@ widget tableIn = do
R.divClass "cell" $ R.blank
R.divClass "cell" $ R.blank
R.divClass "cell" $ R.blank
- (R.switch . R.current . fmap R.leftmost) <$>
+
+ result <-
(R.simpleList paymentRange (paymentRow init paymentCategories))
- DomUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
+ return $
+ ( R.switch . R.current . fmap (R.leftmost . map fst) $ result
+ , R.switch . R.current . fmap (R.leftmost . map snd) $ result
+ )
+
+ ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
R.text $ Msg.get Msg.Payment_Empty
return $ TableOut
- { _tableOut_deletePayment = deletePayment
+ { _tableOut_addPayment = addPayment
+ , _tableOut_deletePayment = deletePayment
}
where
@@ -82,7 +98,7 @@ paymentRow
=> Init
-> Dynamic t [PaymentCategory]
-> Dynamic t Payment
- -> m (Event t Payment)
+ -> m (Event t SavedPayment, Event t Payment)
paymentRow init paymentCategories payment =
R.divClass "row" $ do
@@ -115,7 +131,7 @@ paymentRow init paymentCategories payment =
Nothing -> M.singleton "display" "none"
R.elDynAttr "span" attrs $
- R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of
+ R.dynText $ R.ffor category $ \case
Just c -> _category_name c
_ -> ""
@@ -123,35 +139,68 @@ paymentRow init paymentCategories payment =
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 categoryId = (Maybe.fromMaybe (-1) . fmap _category_id) <$> category
+
+ clonePayment <-
+ R.divClass "cell button" $
+ _buttonOut_clic <$> (Component.button $
+ Component.defaultButtonIn Icon.clone)
+
+ paymentCloned <-
+ Modal.view $ Modal.Input
+ { Modal._input_show = clonePayment
+ , Modal._input_content =
+ Clone.view $ Clone.Input
+ { Clone._input_show = clonePayment
+ , Clone._input_categories = _init_categories init
+ , Clone._input_paymentCategories = paymentCategories
+ , Clone._input_payment = payment
+ , Clone._input_category = categoryId
+ }
+ }
let isFromCurrentUser =
R.ffor
payment
(\p -> _payment_user p == _init_currentUser init)
- R.divClass "cell button" $
- DomUtil.divVisibleIf isFromCurrentUser $
- R.el "button" Icon.edit
+ editPayment <-
+ R.divClass "cell button" $
+ ReflexUtil.divVisibleIf isFromCurrentUser $
+ _buttonOut_clic <$> (Component.button $
+ Component.defaultButtonIn Icon.edit)
+
+ paymentEdited <-
+ Modal.view $ Modal.Input
+ { Modal._input_show = editPayment
+ , Modal._input_content =
+ Edit.view $ Edit.Input
+ { Edit._input_show = editPayment
+ , Edit._input_categories = _init_categories init
+ , Edit._input_paymentCategories = paymentCategories
+ , Edit._input_payment = payment
+ , Edit._input_category = categoryId
+ }
+ }
deletePayment <-
R.divClass "cell button" $
- DomUtil.divVisibleIf isFromCurrentUser $
+ ReflexUtil.divVisibleIf isFromCurrentUser $
_buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn Icon.delete)
- { _buttonIn_class = R.constDyn "deletePayment" })
-
- rec
- modalOut <- Component.modal $ ModalIn
- { _modalIn_show = deletePayment
- , _modalIn_hide = R.leftmost $
- [ _deleteOut_cancel . _modalOut_content $ modalOut
- , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut
- ]
- , _modalIn_content = Delete.view (DeleteIn { _deleteIn_payment = payment })
+ { _buttonIn_class = R.constDyn "deletePayment"
+ })
+
+ paymentDeleted <-
+ Modal.view $ Modal.Input
+ { Modal._input_show = deletePayment
+ , Modal._input_content =
+ Delete.view $ Delete.Input
+ { Delete._input_payment = payment
+ }
}
- return (_deleteOut_validate . _modalOut_content $ modalOut)
+
+ return $ (paymentCloned, paymentDeleted)
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 20:52:09 +0000