diff options
Diffstat (limited to 'client/src/View/Payment/Header.hs')
| -rw-r--r-- | client/src/View/Payment/Header.hs | 187 |
1 files changed, 0 insertions, 187 deletions
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs deleted file mode 100644 index c8ca347..0000000 --- a/client/src/View/Payment/Header.hs +++ /dev/null @@ -1,187 +0,0 @@ -module View.Payment.Header - ( view - , In(..) - , Out(..) - ) where - -import Control.Monad (forM_) -import Control.Monad.IO.Class (liftIO) -import qualified Data.List as L hiding (groupBy) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (NominalDiffTime) -import qualified Data.Time as Time -import qualified Data.Validation as V -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Category, Currency, - ExceedingPayer (..), Frequency (..), - Income (..), Payment (..), - PaymentCategory, SavedPayment (..), - User (..)) -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.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.Form as Form -import View.Payment.Init (Init (..)) - -data In t = In - { _in_init :: Init - , _in_currency :: Currency - , _in_payments :: Dynamic t [Payment] - , _in_searchPayments :: Dynamic t [Payment] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - } - -data Out t = Out - { _out_searchName :: Dynamic t Text - , _out_searchFrequency :: Dynamic t Frequency - , _out_addPayment :: Event t SavedPayment - } - -view :: forall t m. MonadWidget t m => In t -> m (Out t) -view input = - R.divClass "header" $ do - rec - addPayment <- - payerAndAdd - incomes - payments - users - categories - paymentCategories - currency - searchFrequency - let resetSearchName = fmap (const ()) $ addPayment - (searchName, searchFrequency) <- searchLine resetSearchName - - infos (_in_searchPayments input) users currency - - return $ Out - { _out_searchName = searchName - , _out_searchFrequency = searchFrequency - , _out_addPayment = addPayment - } - where - init = _in_init input - incomes = _init_incomes init - initPayments = _init_payments init - payments = _in_payments input - users = _init_users init - categories = _init_categories init - currency = _in_currency input - paymentCategories = _in_paymentCategories input - -payerAndAdd - :: forall t m. MonadWidget t m - => [Income] - -> Dynamic t [Payment] - -> [User] - -> [Category] - -> Dynamic t [PaymentCategory] - -> Currency - -> Dynamic t Frequency - -> m (Event t SavedPayment) -payerAndAdd incomes payments users categories paymentCategories currency frequency = do - time <- liftIO Time.getCurrentTime - R.divClass "payerAndAdd" $ do - - let exceedingPayers = - R.ffor payments $ \ps -> - CM.getExceedingPayers time users incomes $ - filter ((==) Punctual . _payment_frequency) ps - - R.divClass "exceedingPayers" $ - R.simpleList exceedingPayers $ \exceedingPayer -> - R.elClass "span" "exceedingPayer" $ do - R.elClass "span" "userName" $ - R.dynText . R.ffor exceedingPayer $ \ep -> - fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users - R.elClass "span" "amount" $ do - R.text "+ " - R.dynText . R.ffor exceedingPayer $ \ep -> - Format.price currency $ _exceedingPayer_amount ep - - addPayment <- Button._out_clic <$> - (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) - { Button._in_class = R.constDyn "addPayment" - }) - - Modal.view $ Modal.In - { Modal._in_show = addPayment - , Modal._in_content = \_ -> return (R.never, R.never) -- TODO - } - -searchLine - :: forall t m. MonadWidget t m - => Event t () - -> m (Dynamic t Text, Dynamic t Frequency) -searchLine reset = do - R.divClass "searchLine" $ do - searchName <- Input._out_raw <$> (Input.view - ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) - ("" <$ reset) - R.never) - - let frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] - - searchFrequency <- Select._out_raw <$> (Select.view $ Select.In - { Select._in_label = "" - , Select._in_initialValue = Punctual - , Select._in_value = R.never - , Select._in_values = R.constDyn frequencies - , Select._in_reset = R.never - , Select._in_isValid = V.Success - , Select._in_validate = R.never - }) - - return (searchName, searchFrequency) - -infos - :: forall t m. MonadWidget t m - => Dynamic t [Payment] - -> [User] - -> Currency -> m () -infos payments users currency = - R.divClass "infos" $ do - - R.elClass "span" "total" $ do - R.dynText $ do - ps <- payments - let paymentCount = length ps - total = sum . map _payment_cost $ ps - pure . Msg.get $ Msg.Payment_Worth - (T.intercalate " " - [ (Format.number paymentCount) - , if paymentCount > 1 - then Msg.get Msg.Payment_Many - else Msg.get Msg.Payment_One - ]) - (Format.price currency total) - - R.elClass "span" "partition" . R.dynText $ do - ps <- payments - let totalByUser = - L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ ps - pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> - Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name $ CM.findUser userId users) - (Format.price currency userTotal) |