diff options
Diffstat (limited to 'client/src/View/Payment')
| -rw-r--r-- | client/src/View/Payment/Pages.hs | 57 | ||||
| -rw-r--r-- | client/src/View/Payment/Table.hs | 102 |
2 files changed, 92 insertions, 67 deletions
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index f9a2b4e..cf3e115 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment.Pages ( widget @@ -8,35 +7,45 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Event, Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment(..)) +import Common.Model (Payment (..)) +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component import qualified Icon data PagesIn = PagesIn { _pagesIn_payments :: [Payment] } -data PagesOut = PagesOut - { +data PagesOut t = PagesOut + { _pagesOut_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn -> m PagesOut +widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) widget _ = do - R.divClass "pages" $ do - page Icon.doubleLeftBar - page Icon.doubleLeft - page (R.text . T.pack . show $ (1 :: Integer)) - page (R.text . T.pack . show $ (2 :: Integer)) - page (R.text . T.pack . show $ (3 :: Integer)) - page (R.text . T.pack . show $ (4 :: Integer)) - page (R.text . T.pack . show $ (5 :: Integer)) - page Icon.doubleRight - page Icon.doubleRightBar - return $ PagesOut {} - -page :: forall t m. MonadWidget t m => m () -> m () -page content = R.elClass "button" "page" $ content + currentPage <- R.divClass "pages" $ do + a <- page 1 Icon.doubleLeftBar + b <- page 1 Icon.doubleLeft + c <- page 1 (R.text . T.pack . show $ (1 :: Integer)) + d <- page 2 (R.text . T.pack . show $ (2 :: Integer)) + e <- page 3 (R.text . T.pack . show $ (3 :: Integer)) + f <- page 4 (R.text . T.pack . show $ (4 :: Integer)) + g <- page 5 (R.text . T.pack . show $ (5 :: Integer)) + h <- page 5 Icon.doubleRight + i <- page 5 Icon.doubleRightBar + R.holdDyn 1 $ R.leftmost [ a, b, c, d, e, f, g, h, i ] + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + +page :: forall t m. MonadWidget t m => Int -> m () -> m (Event t Int) +page n content = + ((fmap (const n)) . _buttonOut_clic) <$> (Component.button $ ButtonIn + { _buttonIn_class = "page" + , _buttonIn_content = content + , _buttonIn_waiting = R.never + }) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f3eb9a7..734511d 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment.Table ( widget @@ -8,34 +7,40 @@ module View.Payment.Table , TableOut(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List as L -import qualified Data.Map as M -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (MonadWidget, Dynamic) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) -import qualified Common.Model as CM -import qualified Common.Util.Text as T +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Util.Text as T import qualified Common.View.Format as Format import qualified Icon -data TableIn = TableIn +data TableIn t = TableIn { _tableIn_init :: Init + , _tableIn_currentPage :: Dynamic t Int } data TableOut = TableOut { } -widget :: forall t m. MonadWidget t m => TableIn -> m TableOut +visiblePayments :: Int +visiblePayments = 8 + +widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - R.divClass "table" $ + R.dynText (fmap (T.pack . show) . _tableIn_currentPage $ tableIn) + _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name @@ -48,39 +53,50 @@ widget tableIn = do R.divClass "cell" $ R.blank let init = _tableIn_init tableIn payments = _init_payments init - mapM_ - (paymentRow init) - (take 8 . reverse . L.sortOn _payment_date $ payments) + paymentRange = fmap + (\p -> take visiblePayments . drop ((p - 1) * visiblePayments) . reverse . L.sortOn _payment_date $ payments) + (_tableIn_currentPage tableIn) + R.simpleList paymentRange (paymentRow init) return $ TableOut {} -paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = R.divClass "row" $ do - R.divClass "cell name" . R.text $ _payment_name payment - R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment + R.divClass "cell name" . R.dynText . fmap _payment_name $ payment + R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $ payment + + let user = flip fmap payment $ \p -> CM.findUser (_payment_user p) (_init_users init) R.divClass "cell user" $ - case CM.findUser (_payment_user payment) (_init_users init) of - Just user -> R.text (_user_name user) - _ -> R.blank - R.divClass "cell category" $ - case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of - Just category -> - R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ - R.text $ _category_name category - _ -> - R.blank + R.dynText $ flip fmap user $ \mbUser -> case mbUser of + Just u -> _user_name u + _ -> "" + + let category = flip fmap payment $ \p -> findCategory + (_init_categories init) + (_init_paymentCategories init) + (_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 $ flip fmap category $ \mbCategory -> case mbCategory of + Just c -> _category_name c + _ -> "" + R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) - R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date 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 - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.edit - else R.blank - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.delete - else R.blank + let modifyAttrs = flip fmap payment $ \p -> + M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] + R.elDynAttr "div" modifyAttrs $ + R.el "button" $ Icon.edit + R.elDynAttr "div" modifyAttrs $ + R.el "button" $ Icon.delete findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do |