diff options
Diffstat (limited to 'client/src')
| -rw-r--r-- | client/src/Component/Modal.hs | 63 | ||||
| -rw-r--r-- | client/src/Util/Reflex.hs (renamed from client/src/Util/Dom.hs) | 33 | ||||
| -rw-r--r-- | client/src/View/Payment.hs | 14 | ||||
| -rw-r--r-- | client/src/View/Payment/Add.hs | 187 | ||||
| -rw-r--r-- | client/src/View/Payment/Clone.hs | 60 | ||||
| -rw-r--r-- | client/src/View/Payment/Delete.hs | 57 | ||||
| -rw-r--r-- | client/src/View/Payment/Edit.hs | 55 | ||||
| -rw-r--r-- | client/src/View/Payment/Form.hs | 165 | ||||
| -rw-r--r-- | client/src/View/Payment/Header.hs | 39 | ||||
| -rw-r--r-- | client/src/View/Payment/Pages.hs | 14 | ||||
| -rw-r--r-- | client/src/View/Payment/Table.hs | 109 |
11 files changed, 512 insertions, 284 deletions
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 |